- page 307

Info

File

Tác giả: qh2qa06
Bài viết gốc: 336757
Tên lệnh: ttl ttk

Xin lisp tính chiều dài trung bình và DL của thanh thép biến thiên

@qh2qa06:

Bạn là thành viên đã 4 năm mà không chịu khó học hỏi được tí gì sao, cứ dựa mãi vào người khác thì sao mà tiến...

@qh2qa06:

Bạn là thành viên đã 4 năm mà không chịu khó học hỏi được tí gì sao, cứ dựa mãi vào người khác thì sao mà tiến bộ được

Hãy xem lệnh ttk sửa như thế nào rồi tự sửa lệnh ttl

- có phải bạn không chọn đc polyline phải ko ^^, nhoc đã sửa lại chắc ok

(vl-load-com)
;==================
(defun c:TTL (/ old lmax lmin ename1 ename2 dai1 dai2 info1 sl info2  ltb ldelta e1 e2) ;
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(prompt "Chon thanh co chieu dai be nhat:")
(setq lmin (ssget "+.:E:S" '((0 . "*LINE"))))
(if lmin
 (progn
   (setq dai1 0.0)
   (while (setq ename1 (ssname lmin 0))
           (setq dai1 (+ dai1 (Length1 ename1)))
		   (ssdel ename1 lmin))
     (setq dai1 (distof (rtos dai1 2 3)))
  )
)  
 ;=========================================================
(prompt "Chon thanh co chieu dai lon nhat:")
(setq lmax (ssget "+.:E:S" '((0 . "*LINE"))))
(if lmax
 (progn
    (setq dai2 0.0)
   (while (setq ename2 (ssname lmax 0))
           (setq dai2 (+ dai2 (Length1 ename2)))
		   (ssdel ename2 lmax))
     (setq dai2 (distof (rtos dai2 2 3)))
  )
)  
;===========================================================
(setq sl (getint "\nSo luong thanh mun tinh:"))
(setq ltb (distof (rtos (/ (+ dai1 dai2) 2.0) 2 3)))
(if (= (- ltb (fix ltb)) 0.5)
(setq ltb (+ ltb 0.5))
ltb
)
(setq ldelta (* (/ (- dai2 dai1) (- sl 1)) 1000.0))
;==============================================================
(setq e1 (entget (car (entsel "\nchon text ghi ket qua L trung binh:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e1)) "TEXT")
(prompt "Ban chon ko phai la text, ban chon lai hen!!!")
(setq e1 (entget (car (entsel "\nchon text ghi ket qua L trung binh:"))))
(princ "\n")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(entmod (subst (cons 1 (strcat (itoa sl) "`14, L=" (rtos (* ltb 1000) 2 0))) (assoc 1 e1) e1))
;===============================================================
(setq e2 (entget (car (entsel "\nchon dim ghi ket qua L delta:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e2)) "DIMENSION")
(prompt "doi tuong ban chon ko phai la dim, ban chon lai hen!!!")
(setq e2 (entget (car (entsel "\nchon dim ghi ket qua L delta:"))))
(princ "\n")
)
(entmod (subst (cons 1 (strcat (rtos (* dai1 1000) 2 0) "~" (rtos (* dai2 1000) 2 0) ", \U+0394L=" (rtos ldelta 2 0))) (assoc 1 e2) e2))
;======================================================================
(setvar "osmode" old)
(princ "\n")
(princ)
)
;===============================chon thanh co chieu dai ko doi edit vao text co san
(defun c:ttk(/ lx ename3 info3 dai3 e3 old sl dk)
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(prompt "Chon thanh co chieu dai khong doi:")
(setq lx (ssget "+.:E:S" '((0 . "*LINE"))))
(if lx
 (progn
     (setq dai3 0.0)
	 (while (setq ename3 (ssname lx 0))
           (setq dai3 (+ dai3 (Length1 ename3)))
		   (ssdel ename3 lx))
	     (setq dai3 (distof (rtos dai3 2 3)))
	 )
  )
(setq sl (getint "\nSo luong thanh mun tinh:"))
(setq dk (getstring "\nNhap duong kinh Thep:"))
;====================================================
 (setq e3 (entget (car (entsel "\nchon text ghi ket qua L khong doi:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e3)) "TEXT")
(prompt "Ban chon ko phai la text, ban chon lai hen!!!")
(setq e3 (entget (car (entsel "\nchon text ghi ket qua L khong doi:"))))
(princ "\n")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(entmod (subst (cons 1 (strcat (itoa sl) dk ", L=" (rtos (* dai3 1000) 2 0))) (assoc 1 e3) e3))
(setvar "osmode" old)
(princ "\n")
(princ)
)
;=============================================
(defun Length1(e) 
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;=========================================================

- p/s: nói khó cũng ko khó dễ cũng ko phải dễ ^^,với ai chưa pit về lsp chỉ xem qua code dù nhiều lần cũng khó mà nắm đc để có thể tự sửa, bản thân nhoc lúc trước cũng vậy, có khi mún sửa lại hóa ra phá ^^,anh ndtnv đừng khó khăn quá :P

Lâu lắm rồi mới vào diễn đàn để cảm ơn bạn lần nữa. Lsp đã dùng rất tốt. Cảm ơn bạn!

Download lisp

Filename: 336757_ttl_ttk.lsp

Tác giả: vuminhchau
Bài viết gốc: 289730
Tên lệnh: kh

'Tạo khung bản đồ'

Hiện tại mình có lisp tạo khung bản đồ tự động rất hay. Nhưng mình vẫn chưa hài lòng lắm vì chỉ tạo được khung...
>>
Hiện tại mình có lisp tạo khung bản đồ tự động rất hay. Nhưng mình vẫn chưa hài lòng lắm vì chỉ tạo được khung bản đồ ở khi hình chữ nhật ở dạng đứng, nếu hình chữ nhật mà bị nghiêng thì không đúng theo ý muốn.

Mình post lên đây lisp đó, nếu ai cần thì download về dùng tạm.

;;; Tu dong ve khung ban do .
(defun c:kh ();;; (princ "\n                      CHUONG TRINH VE KHUNG BAN DO .")(command "osnap" "Endpoint,Intersection")(setvar "blipmode" 1)   (setq sp (getpoint "\n Chon goc khung thu 1 (Goc trai ben tren): "))   (setq ep (getpoint sp "\n Chon goc khung thu 2 (Goc phai ben duoi): "));   (princ "\n Chon goc khung thu 1 (Goc trai ben tren): ");   (setq sp (getpoint)) ;  (prompt "\n Chon goc khung thu 2 (Goc phai ben duoi): ") ;  (setq ep (getcorner (getpoint)) )  (command "osnap" "off")   (setq tyle (getint "\n Hay cho ty le ban do <500>: "))   (if (= tyle nil) (setq tyle 500.0))(setvar "blipmode" 0);;--- Dat bien chung cho chuong trinh -----  (setq x1 (nth 0 sp)) (setq y1 (nth 1 sp))  (setq x2 (nth 0 ep)) (setq y2 (nth 1 ep))  (setq dayn (/ (* tyle 0.05) 500.0))  (setq kctn (/ tyle 142.857))  (setq ktmk (/ (* tyle 1.75) 500.0))  (setq caoc (/ (* tyle 0.90) 500.0))  (setq dich (/ (* tyle 0.33) 500.0));;;---- ve khung trong ------   (command "LAYER" "M" "KHUNG" "")   (Command "PLINE"             (list x1 y1)             (list x2 y1)             (list x2 y2)             (list x1 y2)             "C"   );;;;-------Ve khung ngoai ----------   (command "LAYER" "M" "KHUNG" "")   (Command "PLINE"             (list (- x1 kctn) (+ y1 kctn)) "w" dayn dayn             (list (+ x2 kctn) (+ y1 kctn))             (list (+ x2 kctn) (- y2 kctn))             (list (- x1 kctn) (- y2 kctn))             "C"   );;;------- Ve net ngang va doc ------- (setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1)) (setq x (* tmpX2 nhay)) (setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1)) (setq y (* tmpY2 nhay));-------------------------------------(command "style" "STANDARD" "" caoc "" "" "" "" "" "")(while (<= x x2)       (if (>= x x1)          (command "LINE" (list x y1) (list x (+ y1 kctn)) ""                   "LINE" (list x y2) (list x (- y2 kctn)) ""                   "TEXT" "C" (list x (+ y1 (/ kctn 2))) 0. (rtos x 2 0)                   "TEXT" "TC" (list x (- y2 (/ kctn 2))) 0. (rtos x 2 0)          )       ) ;endif  (setq x (+ x nhay)))(while (<= y y1)   (setq tmp1 (rtos y 2 0))   (setq len1 (strlen tmp1))   (if ( <= len1 3)      (progn (setq bef "000") (setq aff tmp1))      (progn (setq bef (substr tmp1 1 (- len1 3)))       (setq aff (substr tmp1 (- len1 2) 3))      )   ) ;;if      (if (>= y y2)           (command "LINE" (list x1 y) (list (- x1 kctn) y) ""                    "LINE" (list x2 y) (list (+ x2 kctn) y) ""                    "TEXT" "BC" (list (- x1 (/ kctn 2)) y) 0. bef                    "TEXT" "TC" (list (- x1 (/ kctn 2)) (- y dich)) 0. aff                    "TEXT" "BC" (list (+ x2 (/ kctn 2)) y) 0. bef                    "TEXT" "TC" (list (+ x2 (/ kctn 2)) (- y dich)) 0. aff           )      ); endif  (setq y (+ y nhay)));--------- Ve chu thap --------------(setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1))(setq x (* tmpX2 nhay))(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1))(while (< x x2)  (setq y (* tmpY2 nhay))     (while (< y y1)        (if (and (>= x x1) (>= y y2))           (command "LINE" (list (- x ktmk) y) (list (+ x ktmk) y) "")        )        (if (and (>= y y2) (>= x x1))           (command "LINE" (list x (- y ktmk)) (list x (+ y ktmk)) "")        )       (setq y (+ y nhay))     )  (setq x (+ x nhay)))(command "REDRAW")); End of program
Xin nhờ các pro có thể chỉnh sửa giúp lisp này được ko?
Với thuật toán như trên, mình muốn quét 1 lần tất cả các hình như nhật (kể cả các hình chữ nhật bị nghiêng) ta tạo được các mắt lưới dấu thập (các mắt lưới đều song song với trục X và trục Y) đồng thời trên khung ghi text các tọa độ của mắt lưới đó. Mình upload ví dụ lên đây. Kính mong các Pro giúp đỡ

Ví dụ : http://www.4shared.com/file/bMvNVwMM/khungtoado.html

Cảm ơn mọi người đã quan tâm.

Chương trình này mình đã dùng ở TEDIPORT nhưng đó là phần mềm tích hợp trong Cad phải cài đặt

Nó tên là EGS hay gì đó mà lâu rồi mình không nhớ nổi. Trên khung mình có thể ghi theo tọa độ X Y hay tọa độ địa lý B L đều được hết

Nếu ai có phần mềm đó có thể gửi cho mình được không?

Bạn có thể upload lên diễn đàn để mọi người cùng dùng hoặc gửi vào hòm thư: heaven2407@gmal.com

Chân thành cảm ơn

Similar topics from web:

-: Lisp vẽ pline mũi tên 2 đầu

Sử dụng AutoLisp trong AutoCad

-: Lisp tạo và chỉnh sửa menu.

Trí tuệ nhân tạo – Wikipedia tiếng Việt

-: Lisp rải đối tượng theo đường dẩn bổ sung điểm xuất phát.

Download Phần mềm thống kê cốt thép TIP

-: Hoàn thiện lisp rải đối tượng theo đường dẩn.

Vẽ trắc ngang xử lý đất yếu với Autolisp

Lisp tạo khung viewport bằng cách chọn khung bên Model

Kinh ngiệm dùng CAD và LISP

TVplot

Học Inventor tại Hà Nội

Khung tên để tạo LISP

TH3D

AutoLisp
====================

- Nhờ anh và các anh sửa giúp em cái code trên để khi vẽ khung và xuất tọa độ tại bản vẽ giống như bản vẽ lần #22 của anh. (cụ thể ở code trên cần sửa Text Times New Roman tách 3 số đầu giống như bài post #22 và khung tọa độ cũng giống thế)dạ cảm ơn nhiều!.

- xin lỗi vì em không thể post file hoặc hình ảnh lên đây được vì chức năng up mấy ngày hôm nay không thấy hiện lên.

<<

Download lisp

Filename: 289730_kh.lsp

Tác giả: tientracdia
Bài viết gốc: 220582
Tên lệnh: klg1

lisp tính ngược giá trị của mắt lưới san nền ?

ui sr, ko đọc kỹ đề bài ^^! Edit ...

(defun GET-TEXT ()
 (princ "\nChon cac cao trinh san lap <TEXT>: ")
 (while (null...
>>

ui sr, ko đọc kỹ đề bài ^^! Edit ...

(defun GET-TEXT ()
 (princ "\nChon cac cao trinh san lap <TEXT>: ")
 (while (null (setq Hsl (ssget '((0 . "TEXT")))))
(princ "\n**You selected NOTHING!**")
 )
)
(defun c:KLG1 (/ DT ENT HSL ID INDEX RESULT TXT VALUE KL)
 (GET-TEXT)
 (while (/= Hsl nil)
(while
 	(or (null
(setq dt (car (entsel "\nDien tich o: ")))
  )
  (/= (cdr (assoc 0 (entget dt))) "TEXT")
  (null (numberp (read (cdr (assoc 1 (entget dt))))))
 	)
  	(princ "\nDien tich o: ")
)
(while
 	(or (null
(setq kl (car (entsel "\nKhoi luong: ")))
  )
  (/= (cdr (assoc 0 (entget kl))) "TEXT")
  (null (numberp (read (cdr (assoc 1 (entget kl))))))
 	)
  	(princ "\nKhoi luong: ")
)
(setq dt (atof (cdr (assoc 1 (entget dt)))))
(setq kl (atof (cdr (assoc 1 (entget kl)))))
(setq index 0
  id 0
  result 0
)
(repeat (sslength Hsl)
 	(setq ent   (entget (ssname Hsl index))
value (read (cdr (assoc 1 ent)))
index (1+ index)
 	)
 	(if (numberp value)
  (setq result (+ result value)
 id 	(1+ id)
  )
 	)
)
(setq result (- (/ (*  kl (1+ id)) dt) result))
(while (null (setq txt (entsel "\nChoose TEXT to replace: ")))
 	(princ "\n**You selected NOTHING!**")
)
(setq txt (entget (car txt))
  txt (subst (cons 1 (rtos result 2 2)) (assoc 1 txt) txt)
)
(entmod txt)
(setq Hsl (ssget '((0 . "TEXT"))))
 )
 (princ)
)

@girl: đây là lisp mình viết lâu rùi, đáp ứng chính xác nhu cầu của bạn. (Trước đây mình cũng làm san nền, hay explode HS để chỉnh sửa ;) ).

(defun GET-TEXT ()
 (princ "\nChon cac cao trinh san lap <TEXT>: ")
 (while (null (setq Hsl (ssget '((0 . "TEXT")))))
(princ "\n**You selected NOTHING!**")
 )
)
(defun c:KLG (/ DT ENT HSL ID INDEX RESULT TXT VALUE)
 (GET-TEXT)
 (while (/= Hsl nil)
(while
 	(or (null
(setq dt (car (entsel "\nDien tich o: ")))
  )
  (/= (cdr (assoc 0 (entget dt))) "TEXT")
  (null (numberp (read (cdr (assoc 1 (entget dt))))))
 	)
  	(princ "\nDien tich o: ")
)
(setq dt (atof (cdr (assoc 1 (entget dt)))))
(setq index 0
  id 0
  result 0
)
(princ "\n>>Expression: (")
(repeat (sslength Hsl)
 	(setq ent   (entget (ssname Hsl index))
value (read (cdr (assoc 1 ent)))
index (1+ index)
 	)
 	(if (numberp value)
(progn
  (setq result (+ result value)
 id 	(1+ id)
  )
  (if (/= index 1)
(princ " + ")
  )
  (princ (rtos value 2 2))
)
 	)
)
(setq result (/ (float result) id))
(princ (strcat ") / " (rtos id 2 0)))
(princ (strcat "\n>>Htb = " (rtos result 2 2)))
(princ (strcat "\nDien tich = " (rtos dt 2 2)))
(setq result (* result dt))
(princ (strcat "\n>>Volumn = " (rtos result 2 2)))
(while (null (setq txt (entsel "\nChoose TEXT to replace: ")))
 	(princ "\n**You selected NOTHING!**")
)
(setq txt (entget (car txt))
  txt (subst (cons 1 (rtos result 2 2)) (assoc 1 txt) txt)
)
(entmod txt)
(setq Hsl (ssget '((0 . "TEXT"))))
 )
 (princ)
)

;;;-----------------------------

Mình nhờ các Anh chỉnh giúp mình để chỉnh Lisp trên để thực hiện tính chênh cao trung bình các ô lưới :

1. Chọn các text Chênh cao trung bình, xong enter chọn text thay thế nếu chưa có thì ghi kết quả CCTB tại điểm chọn và ghi nhớ nó,

2. Tiếp chọn Text Diện tích, thực hiện phép tính ( CCTB*Diện tích= Khối lượng )

3. Chọn text ghi thay thế Khối lượng, nếu chưa có thì ghi vào điểm chọn.

Rất Mong được các anh giúp

Download lisp

Filename: 220582_klg1.lsp

Tác giả: Doan Nguyen Van
Bài viết gốc: 442719
Tên lệnh: te

Xin lisp chuyển mỗi đối tượng sang mỗi layer khác nhau.

23 giờ trước, thietke08 đã nói:

Chào mọi người, hiện tại em...
>>
23 giờ trước, thietke08 đã nói:

Chào mọi người, hiện tại em tìm kiếm lisp có thể đổi các đối tượng thành các layer khác nhau, như trong hình là mỗi polyline sẽ là một layer, layer được đánh số từ 1 đến 255 với màu tương ứng.

Em tìm mà vẫn chưa thấy nên mọi người có thì cho e xin lisp này, vì em đổi thủ công là rất lâu.

Em cảm ơn.

Viết mò, k biết đúng ý chủ thớt không
(defun c:te (/ x i)
  (foreach x (acet-ss-to-list (ssget (list (cons 0 "*LINE"))))
    (if (not i) (setq i 1) (setq i (1+ i)))
	    (if (< i 257) (progn (if (not (tblsearch "LAYER" (itoa i)))
	       (COMMAND "-LAYER" "M" (itoa i) "C" (itoa i) "" "" ""))
	      (vla-put-layer (vlax-ename->vla-object x) (itoa i)))))
	  )
<<

Download lisp

Filename: 442719_te.lsp

Tác giả: 3d.decor
Bài viết gốc: 150567
Tên lệnh: dlay

Lisp chuyển nhiều layer về 1 layer

Hề hề hề,

Bạn xài thử cái này coi sao hỉ...

(defun c:dlay (/ ss ssl en enl lay)
(vl-load-com)
(command...
>>

Download lisp

Filename: 150567_dlay.lsp

Tác giả: ngokiet
Bài viết gốc: 443803
Tên lệnh: test

Xóa các đối tượng giao nhau với Hình chữ nhật

Bác dùng thử:

(defun c:test()
(c:fs)
(command "_erase"(ssget "_I") ""))

Download lisp

Filename: 443803_test.lsp

Tác giả: binharch77
Bài viết gốc: 56746
Tên lệnh: xminsert

Đố vui

;;;CADALYST 01/07 Tip 2169: XMINSERT.lsp Explode Minsert © 2007 Jeffery P. Sanders

;;;--- XMINSERT - Replace a minsert entity with individual blocks arrayed.
;;;
;;;
;;;
;;;--- This program...
>>

;;;CADALYST 01/07 Tip 2169: XMINSERT.lsp Explode Minsert © 2007 Jeffery P. Sanders

;;;--- XMINSERT - Replace a minsert entity with individual blocks arrayed.
;;;
;;;
;;;
;;;--- This program will delete the XMINSERT entity after an array is created.
;;; It will restore the attribute values contained inside the minsert.
(defun C:XMINSERT()
;;;--- Function to change an attributes value

(defun repAttVal(en tagName newVal)

;;;--- Get the DXF group codes of the entity
(setq enlist(entget en))

;;;--- Get the name of the block
(setq blkName(cdr(assoc 2 enlist)))

;;;--- Check to see if the block's attribute flag is there
(if(cdr(assoc 66 enlist))
(progn

;;;--- Get the entity name
(setq en(entnext en))

;;;--- Get the entity dxf group codes
(setq enlist(entget en))

;;;--- Get the type of block
(setq blkType (cdr(assoc 0 enlist)))

;;;--- If group 66 then there are attributes nested inside this block
(setq group66(cdr(assoc 66 enlist)))

;;;--- Loop while the type is an attribute or a nested attribute exist
(while(or (= blkType "ATTRIB")(= group66 1))

;;;--- Get the block type 
(setq blkType (cdr(assoc 0 enlist)))

;;;--- Get the block name 
(setq entName (cdr(assoc 2 enlist)))

;;;--- Check to see if this is the first attribute
(if(= blkType "ATTRIB")
(progn

;;;--- Get the attribute tag
(setq attTag(cdr(assoc 2 enlist)))

;;;--- Get the value of the attribute
(setq attVal(cdr(assoc 1 enlist))) 

;;;--- If this tag matches our search tag name
(if(= (strcase tagName)(strcase attTag))
(progn

;;;--- Replace the attribute's value
(setq enlist(subst (cons 1 newVal)(assoc 1 enlist)enlist))
(entmod enlist)
(entupd en)
)
)
)
)
;;;--- Get the next sub-entity or nested entity as you will
(setq en(entnext en))

;;;--- Get the dxf group codes of the next sub-entity
(setq enlist(entget en))

;;;--- Get the block type of the next sub-entity
(setq blkType (cdr(assoc 0 enlist)))

;;;--- See if the dxf group code 66 exist. if so, there are more nested attributes
(setq group66(cdr(assoc 66 enlist)))

)
)
)
)
;;;--- Function to return a list of tags and values from attributes in a block

(defun getAttData(en / attList attVal enlist blkType group66)

(setq attList(list))

;;;--- Get the DXF group codes of the entity
(setq enlist(entget en))

;;;--- Check to see if the block's attribute flag is there
(if(cdr(assoc 66 enlist))
(progn

;;;--- Get the entity name
(setq en(entnext en))

;;;--- Get the entity dxf group codes
(setq enlist(entget en))

;;;--- Get the type of block
(setq blkType (cdr(assoc 0 enlist)))

;;;--- If group 66 then there are attributes nested inside this block
(setq group66(cdr(assoc 66 enlist)))

;;;--- Loop while the type is an attribute or a nested attribute exist
(while(or (= blkType "ATTRIB")(= group66 1))

;;;--- Get the block type 
(setq blkType (cdr(assoc 0 enlist)))

;;;--- Check to see if this is an attribute
(if(= blkType "ATTRIB")
(progn

;;;--- If this matches your tag name
(setq attTag(cdr(assoc 2 enlist)))

;;;--- Get the value of the attribute
(setq attVal(cdr(assoc 1 enlist))) 

(setq attList(append attList (list (list attTag attVal))))
)
)

;;;--- Get the next sub-entity or nested entity as you will
(setq en(entnext en))

;;;--- Get the dxf group codes of the next sub-entity
(setq enlist(entget en))

;;;--- Get the block type of the next sub-entity
(setq blkType (cdr(assoc 0 enlist)))

;;;--- See if the dxf group code 66 exist. if so, there are more nested attributes
(setq group66(cdr(assoc 66 enlist)))

)
)
)
attList
)
;;;--- Main application

(setvar "cmdecho" 0)

;;;--- If the user selects an object
(if(setq ent(entsel "\nSelect MINSERT: "))
(progn

;;;--- If it is an object selected and not an point
(if(setq en(car ent))
(progn

;;;--- Make a copy of the entity name
(setq origEn en)

;;;--- Get the entities dxf group codes
(setq enlist(entget en))

;;;--- Get the data from the minsert
(setq blkName(cdr(assoc 2 enlist)))
(setq layName(cdr(assoc 8 enlist)))
(setq insPt(cdr(assoc 10 enlist)))
(setq cols(cdr(assoc 70 enlist)))
(setq rows(cdr(assoc 71 enlist)))
(setq colWidth(cdr(assoc 44 enlist)))
(setq rowWidth(cdr(assoc 45 enlist)))
(setq xScale(cdr(assoc 41 enlist)))
(setq yScale(cdr(assoc 42 enlist)))
(setq rAngle(cdr(assoc 50 enlist)))

;;;--- If group code 66 exist 
(if(assoc 66 enlist)

;;;--- Get the group code 66
(setq group66(cdr(assoc 66 enlist)))
)

;;;--- If it equals 1 then attributes follow..so
(if(= group66 1)
(progn

;;;--- Turn off attribute request during insertion
(setq oldAttReq(getvar "attreq"))
(setvar "attreq" 0)

;;;--- Get the attribute tags and values
(setq attList(getAttData en))
)
)

;;;--- Insert the new block
(command "-insert" blkName insPt xScale yScale (angtos rAngle))

;;;--- If it had attributes ...
(if(= group66 1)

;;;--- Reset the attribute request
(setvar "attreq" oldAttReq)
) 

;;;--- Get the last entity created...
(if(setq en(entlast))
(progn

;;;--- Get the group codes
(setq enlist(entget en))

;;;--- Get the name of the block
(setq blkName2(cdr(assoc 2 enlist)))

;;;--- If this is the block I just created... 
(if(= blkName blkName2)
(progn

;;;--- If it has an attributes flag code...
(if(assoc 66 enlist)
(progn

;;;--- And attributes follow  
(if(= (cdr(assoc 66 enlist)) 1)
(progn

;;;--- Replace the attribute values 
(foreach a attList
(repAttVal en (car a) (cadr a))
)
)
)
)
) 

;;;--- Delete the minsert entity
(entdel origEn)

;;;--- Array the new block to represent the minsert entity
(command "-array" en "" "R" rows cols rowWidth colWidth)

;;;--- Inform the user
(setq str(itoa (* rows cols)))
(alert (strcat "Deleted MINSERT and added (" str ") blocks."))
)
)
)
)
)
)
)
)
(princ)
)

ôi.... cái này hay quá.... file này có thể bị khoá rồi.... các đồng chí làm lại việc rã đồi tượng cái này giùm mình xem....

http://www.cadviet.com/upfiles/Drawing1_39.dwg

cố lên...

pó tay...

hehhe :cheers:

Download lisp

Filename: 56746_xminsert.lsp

Tác giả: ngokiet
Bài viết gốc: 443380
Tên lệnh: ddk

Nhờ các bác viết lisp hoán đổi giá trị kích thước đường kính giúp em với!!!

6 giờ trước, Nguyen Hoang Thuy Linh đã nói:

Bác ngokiet...
>>
6 giờ trước, Nguyen Hoang Thuy Linh đã nói:

Bác ngokiet đúng ý em quá rồi, em thử good lắm a, bác fix +0.5 đúng là cái em mắc phải mà em không nghỉ tới, vì file của em Import từ cái file đuôi .igs nên thỉnh thoảng nó củng ra số gần đúng. nếu fix + - 0.5 thì ok hơn, bác chỉ e sửa thêm -0.5 nửa nhé!!!

Mình viết fix +0.5 là làm tròn số. ví dụ như 74.5 -> 75.49 thì nó thành 75. Chứ fix ko thì 74.999 nó chỉ ra 74 thôi.

Nếu sai số nhiều hơn thì dùng cái này
(defun c:ddk ( / ndc  ent)
  (setq ent (entlast))
  (command "DIMDIAMETER")
  (while (< 0 (getvar "CMDACTIVE")) (command pause))
  (if (/= ent (setq ent (entlast)))
    (Progn
      (setq ndc (cdr(assoc 42 (entget ent))))
      (if (vl-some '(lambda(x)
		      (if (equal ndc (car x) 0.999) (setq ndc (cdr x))))
		   '((75  . "5K-10A")  (80 . "5K-15A")   (85 . "5K-20A")
		     (95  . "5K-25A")  (115 . "5K-32A")  (120 . "5K-40A")
		     (130 . "5K-50A")  (155 . "5K-65A")  (180 . "5K-80A")
		     (190 . "5K-900A") (200 . "5K-100A") (235 . "5K-125A")
		     (265 . "5K-150A") (300 . "5K-175A") (320 . "5K-200A")
		     (345 . "5K-225A") (385 . "5K-250A") (430 . "5K-300A")
		     (480 . "5K-350A")))
	(entmod (list (cons -1 ent) (cons 1 ndc))))))
  (princ))
@NTHAHT Dùng vl-remove thì nó so sánh toàn bộ. Mình dùng vl-some thì khi có kết quả thì nó ngừng.

Còn bác muốn tự động vào layer thì cứ tạo layer rồi sử dụng dimlayer là được. Không cần chèn vào lisp cho rối.

<<

Download lisp

Filename: 443380_ddk.lsp

Tác giả: hieptran891
Bài viết gốc: 235363
Tên lệnh: ft df dfx dx

Lisp căn lề text: Left, Center, Right và Fit (giống word)

Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)
>>

Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)

(defun c:ft()(setq txt (ssget '((0 . "*TEXT"))))(setq mau (entget (car (entsel "\nChon text chuan"))))(command "undo" "begin")(setq oldos (getvar "osmode"))(setq olcol (getvar "CEColor"))(setq ollay (getvar "Clayer"))(setq olstyle (getvar "textstyle"))(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)(setq h (cdr(assoc 40 mau)))(setq x1 (cdr(assoc 10 mau)))(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))(setq canle (cond (canle) ("Left")))(initget "Left Center Right Fit")(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))(repeat (sslength txt)(setq txt_ent (entget (ssname txt i)))(setq txt_val (cdr(assoc 1 txt_ent)))(setq txt_st (cdr(assoc 7 txt_ent)))(setq txt_lay (cdr(assoc 8 txt_ent)))(setq txt_h (cdr(assoc 40 txt_ent)))(setq txt_fctr (cdr(assoc 41 txt_ent)))(setq txt_clr (cdr(assoc 62 txt_ent)))(setq y1 (cdr(assoc 10 txt_ent)))(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))(setq pt1 (list (car x1) (cadr y1)))(setq pt2 (list (car x2) (cadr y1)))(setq pt3 (list (car x3) (cadr y1)))(command "-style" txt_st "" "" txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))(setq i (+ i 1))(command "color" "bylayer"));repeat(setvar "textstyle" olstyle)(setvar "Clayer" ollay)(setvar "CECOLOR" olcol)(setvar "osmode" oldos)(command "erase" txt "")(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")(command "undo" "end"));defun;====================================================================;dan deu khoang cach cac hang text theo phuong Y;====================================================================(defun ss2ent (ss / sodt index lstent)(setq 	sodt (if ss (sslength ss) 0)	index 0)(repeat sodt(setq 	ent (ssname ss index)	index (1+ index)	lstent (cons ent lstent));setq);repeat(reverse lstent))(defun c:df()(setq oldos (getvar "osmode"))(setq 	ss (ssget '((0 . "*TEXT")))	lst (ss2ent ss)	lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))	lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2)))))));setq(command "undo" "begin")(setvar "osmode" 15359)(setq kc (getdist "\n Nhap khoang cach giua cac text"))(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 a2 (ssadd))(setq mau (entget (car (entsel "\nChon text chuan"))))(setq ptmau (cdr(assoc 10 mau)))(setq ym (cadr ptmau))(foreach e lst(setq ent (entget e))(setq dcuoi (cdr(assoc 10 ent)))(setq yi (cadr dcuoi))(setq ddauu (list (car dcuoi) (- (cadr ddau) (* i kc))))(if (= yi ym) (setq ptgoc (list (car dcuoi) (- (cadr ddau) (* i kc)))))(setvar "osmode" 0)(command "move" e "" dcuoi ddauu)(setq 	a2 (ssadd e a2))(setq i (1+ i)));foreach(command "move" a2 "" ptgoc ptmau)(setvar "osmode" oldos)(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")(command "undo" "end")(Princ));======================================================================;dan deu khoang cach cac text theo phuong X;======================================================================(defun c:dfx()(setq oldos (getvar "osmode"))(setq 	ss (ssget '((0 . "*TEXT")))	lst (ss2ent ss)	lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))	lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2)))))));setq(command "undo" "begin")(setvar "osmode" 15359)(setq kc (getdist "\n Nhap khoang cach giua cac text"))(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 di 0 a2 (ssadd))(setq mau (entget (car (entsel "\nChon text chuan"))))(setq ptmau (cdr(assoc 10 mau)))(setq xm (car ptmau))(foreach e lst(setq ent (entget e))(setq pti (cdr(assoc 10 ent)))(setq xi (car pti))(setq ddauu (list (+ (car ddau) di (* i kc)) (cadr ddau)))(if (= xi xm) (setq ptgoc (list (+ (car ddau) di (* i kc)) (cadr ddau))))(setq TBi  (textbox ent) LCi  (car TBi) RCi (cadr TBi) dii (distance LCi RCi) di (+ di dii))(setvar "osmode" 0)(command "move" e "" pti ddauu)(setq 	a2 (ssadd e a2))(setq i (1+ i)));foreach(command "move" a2 "" ptgoc ptmau)(setvar "osmode" oldos)(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")(command "undo" "end")(Princ));==================================================================;Sap xep text thang hang (co cung tung do Y);==================================================================(defun c:dx()(setq oldos (getvar "osmode"))(setq txt (ssget '((0 . "TEXT"))))(command "undo" "begin")(setq ym (cadr (cdr(assoc 10 (entget (car (entsel "\nChon text chuan")))))) i 0)(repeat (sslength txt)(setq txt_pt (cdr(assoc 10 (entget (ssname txt i)))))(setq ptcuoi (list (car txt_pt) ym))(setvar "osmode" 0)(command "move" (ssname txt i) "" txt_pt ptcuoi)(setq i (+ i 1)));repeat(setvar "osmode" oldos)(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")(command "undo" "end")(Princ))

Sao em tải về ! tấy cả các đoạn mã trong lisp đều nằm trên 1 dòng hết !

hay tại máy em bị lỗi !

toàn bộ mã lisp nằm trên 1 dòng ! lisp có chạy không vậy các đại ca !

Download lisp

Filename: 235363_ft_df_dfx_dx.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 74888
Tên lệnh: std

Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình có lisp được một anh bạn cho (vẽ trắc dọc ống cấp nước). Lisp sử dụng rất tốt nhưng có những cái chưa hoàn thiện lắm và rất còn bất tiện cho người...

Mình có lisp được một anh bạn cho (vẽ trắc dọc ống cấp nước). Lisp sử dụng rất tốt nhưng có những cái chưa hoàn thiện lắm và rất còn bất tiện cho người sử dụng

Đối với lisp mình chỉ mới bắt đầu tìm hiểu nên còn lơ mơ lắm. Có vấn đề muốn nhờ các bạn trên diễn đàn chỉ bảo thêm (mình chưa hiểu lắm đừng cười mình nha)

Mình trích một đoạn code (của đoạn code dưới) như thế này:

.........

(setq

Tln (getint "\nTy le ngang 1/x (100, 200, 500, 1000); x="))

Tld (getint "\nTy le dung 1/y (100, 200); y="))

Tn (/ 1000.0 Tln)

Td (/ 1000.0 Tld)

)

........

Mình muốn gán tỷ lệ đứng và ngang bằng cách dùng hàm strcat

"text" "j" "ml" Pta5 2.5 0.0 ((strcat "TYÛ LEÄ NGANG: 1/" (rtos Tln))

"text" "j" "ml" Pta6 2.5 0.0 (strcat "TYÛ LEÄ ÑÖÙNG: 1/" (rtos Tld))

nhưng khi nhập tỷ lệ đứng và ngang xong thì thoát luôn.

Nhờ các bạn giải thích và hướng dẫn giúp mình. Cảm ơn tất cả

;--------------------------------
;;function set parameter
(defun Init ()
(setvar "BLIPMODE" 0)
(setvar "CMDECHO" 0)
(setvar "ANGBASE" 0)
);;
;--------------------------------
;;function return parameter
(defun Reinit ()
(setvar "BLIPMODE" 0)
(setvar "CMDECHO" 1)
(setvar "ANGBASE" 0)
)
;--------------------------------
;;function change degree to radian
(defun doi (a)
(* PI (/ a 180))
)
;--------------------------------
;function set corner by radian
(defun doi1 ()
(setq a 1.5707965 a45 0.78539825
b 3.141593 b45 -0.78539825
c 4.7123895
)
)
;--------------------------------
;;function change radian to degree
(defun doi2 (d)
(* 180 (/ d pi))
)
;;
;--------------------------------
; make layer
(defun taolop ()
(command
"-OSNAP" "OFF"
"layer" "m" "manh" "c" "252" "" "l" "continuous" "manh" "lw" "0.2" "" ""
"layer" "m" "giong" "c" "252" "" "l" "continuous" "giong" "lw" "0.2" "" ""
"layer" "m" "bao" "c" "1" "" "l" "continuous" "bao" "lw" "0.25" "" ""
"layer" "m" "ong" "c" "5" "ong" "l" "continuous" "ong" "lw" "0.3" "" "" 
"layer" "m" "chua" "c" "3" "" "l" "continuous" "" ""
"layer" "m" "dat" "c" "16" "" "l" "continuous" "dat" "lw" "0.1" "" ""
"layer" "m" "chuv" "c" "3" "" "l" "continuous" "" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"style" "chua" "romans.shx" "" "0.7" "" "" "" ""
)
)
;
;--------------------------------
;---------------------------------
;1 ENDP 2 MID 4 CEN 8 NODE 16 QUA 32 INT 64 INS 128 PER 256 TAN 512 NEA 1024 QUI
;;ONAP ENDP INT(MID) NEAR
(defun onap ()
(setvar "OSMODE" (+ 1 32 512))
)
;;;;ONAP ENDP INT(MID) CEN
(defun onap1 ()
(setvar "OSMODE" (+ 1 4 32))
)
;;;
;;;;ONAP ENDP INT(MID) CEN
(defun onap2 ()
(setvar "OSMODE" (+ 1 2 4 16 32 128 512))
)
;;;;;;
(defun ofnap ()
(command "-OSNAP" "OFF" )
)
;----------------------------(ofnap) (onap2)
(defun COCSS()
(doi1)
(setq
i 1
j 0
Ess1 (+ Ess 1)
Ptssx (polar Ptss 0 -1) Ptssx1 (polar Ptssx a (* Esn Td))
Ptssy (polar Ptss 0 1) Ptssy1 (polar Ptssy a (* Esn Td))
)
(Repeat Esn
(setq Ess2 (rtos Ess1 2 2)
Ptss2 (polar Ptss 0 (* i 0.5))
Ptss21 (polar Ptss2 a (* j Td)) Ptss22 (polar Ptss21 a Td)
Ptss3 (polar Ptss 0 -1)
Ptss31 (polar Ptss3 a (+ (* j Td) Td)) Ptss32 (polar Ptss31 0 -5)
Ptss33 (polar Ptss32 0 -1)
)
(command
"layer" "s" "manh" ""
"pline" Ptss21 "w" 1.0 1.0 Ptss22 ""
"line" Ptss31 Ptss32 ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "mr" Ptss33 2.5 0.0 (strcat Ess2)
)
(setq
i (* i -1)
j (+ j 1)
Ess1 (+ Ess1 1)
)
);endrepeat
(command "layer" "s" "manh" "" "pline" Ptssx "w" 0.0 0.0 Ptssx1 Ptssy1 Ptssy ""
)
);end function comparation (princ lis)
;==========================
;function main
(defun C:STD ()
(setvar "dimzin" 0)
(Init)
(taolop)
(doi1)
;-----------------------------------------
;-----------------------------------------
(Princ "\n**Day la chuong trinh ve TRAC DOC duoc viet boi Anh NGUYEN NGOC QUANG**")
(setq
Tln (getint "\nTy le ngang 1/x (100, 200, 500, 1000); x="))
Tld (getint "\nTy le dung 1/y (100, 200); y="))
Tn (/ 1000.0 Tln)
Td (/ 1000.0 Tld)
)
;-----------------------------------------
(setq LisLkcd1 nil LisLkcd nil
LisLkcdo nil)
(initget "Moi Tieptuc")
(Princ "\n")
(setq Ansertt (getint "\nVe moi hay tiep tuc  :")
)
(cond
((= Ansertt 1)
(setq
Kcdo 0 LisLkcdo (cons Kcdo LisLkcdo)
Kcd 0 LisLkcd1 (cons Kcd LisLkcd1)
LisLkcd LisLkcdo)
)
((= Ansertt 2)
(setq
Kcdo (getreal "\nChieu dai tai coc tiep theo (m):");distance 2 station
Kcd (* Kcdo Tn) ; distance
LisLkcd (cons (- Kcdo Kcdo) LisLkcd)
LisLkcdo (cons Kcdo LisLkcdo)
LisLkcd1 (cons Kcd LisLkcd1))
)
)
(progn
;------------------------------------(princ lis)
(onap)
(setq Pta (getpoint "\nChon diem bat dau ve :")
Pta1 (polar pta 0 60) 
Pta2 (polar pta 0 5) 
Pta3 (polar pta 0 60)
Pta4 (polar pta 0 14.75)
Pta5 (polar pta2 a 95)
Pta6 (polar pta4 a 90)
Ptss1 (polar pta 0 57) 
Ptss (polar Ptss1 a 70) 
Ptsg1 (polar pta 0 60)
Ptsg (polar Ptsg1 a 15)
Ess (getreal "\nCao do so sanh :")
Esn (getint "\nSo moc so sanh :")
Es (rtos Ess 2 2)
VL (getint "\nVat lieu ong :")
D (getreal "\nDuong kinh ong :")
Ho (getreal "\nDo sau chon ong ban dau (m):")
kcong (getreal "\nThe hien MAT CAT DOC ONG :")    ;;;;;;duyvietthem;;;;;;;;;;
i 0
LisCSS '("" "TEÂN COÏC"
"" "GOÙC QUAY MAËT BAÈNG (0%%176)"
"" "KHOAÛNG CAÙCH COÄNG DOÀN (m)"
"" "ÑÖÔØNG KÍNH - ÑOÄ DOÁC (%)"
"" "ÑOÄ SAÂU CHOÂN OÁNG (m)"
"" "CAO ÑOÄ ÑAÙY OÁNG (m)"
"" "CAO ÑOÄ MAËT ÑAÁT (m)"
"" "COÁT SO SAÙNH")
LisTs '("Cot mat dat coc so" "Do doc doan ong giua hai coc"
"Khoang cach giua hai coc"
"Goc quay mat bang coc so")
LisVL '("STK" "uPVC" "THEÙP" "GANG" "BEÂ TOÂNG" "BTCT" "SAØNH" "HDPE")
Lismd nil Lisdo nil LisHo nil Lisi nil Lisio nil LisLkc nil LisLkco nil
LisTcoc nil LisGoc nil LisDeltaMD nil LisdeltaDO nil
)
(ofnap)
;--------
;-------------------------------------------
;data stake no.
(Princ "\n**Neu khong muon ky tu dau cua Coc la mot Chu Cai (VD:A, B...) ma la mot so thuc 
(VD:1, 2...) thì nhan phim Space bar de tiep tuc**")
(setq k (getint "\nSo coc:")
CTc (getstring "\nKy tu dau cua coc:")
Tcoc (getint "\nTen coc dau tien hoac tiep theo:")
Ki Tcoc
i1 Tcoc
i2 Tcoc
i3 Tcoc
i4 Tcoc
i5 Tcoc
)
(repeat k
(progn
(setq
LisTcoc (cons Tcoc LisTcoc)
Tcoc (1+ Tcoc)
)
);endprogn
);endrepeat;(princ Lis)
(setq LisTcoc (reverse LisTcoc))
;-------------------------------------------
;data ground level.
(repeat k
(progn
(print (nth 0 LisTs)) (prin1 CTc) (prin1 Ki)
(setq
Cmdo (getreal "\nCao do mat dat (m) :")
Cmd Cmdo
Lismd (cons Cmd Lismd)
Ki (1+ Ki)
)
);endprogn
);endrepeat;(princ Lis)
(setq Lismd (reverse Lismd))
;-------------------------------------------
;data gradient.
(repeat (- k 1)
(progn
(print (nth 1 LisTs)) (prin1 CTc) (prin1 i1) (prin1 CTc) (prin1 (+ i1 1))
(setq
io (getreal "\nDo doc dat ong  (%) :")
io1 (/ io 1) Lisi (cons io1 Lisi)
io2 (* io 1000) Lisio (cons io2 Lisio)
i1 (1+ i1)
)
);endprogn
);endrepeat;(princ Lis)
(setq Lisi (reverse Lisi) Lisio (reverse Lisio))
;-------------------------------------------
;data distance.
(repeat (- k 1)
(progn
(print (nth 2 LisTs)) (prin1 CTc) (prin1 i2) (prin1 CTc) (prin1 (+ i2 1))
(setq
Kco (getreal "\nKhoang cach giua hai coc (m):");distance 2 station
Kc (* Kco Tn) ; distance
LisLkco (cons Kco LisLkco)
LisLkc (cons Kc LisLkc)
i2 (1+ i2)
)
);endprogn
);endrepeat;(princ Lis)
(setq LisLkc (reverse LisLkc) LisLkco (reverse LisLkco))
;----------------------------------------
;mapcar Kcdo Kcd1
(setq n1 0 Kcd1 0)
;Kcdo 0 LisLkcdo (cons Kcdo LisLkcdo)
;Kcd 0 LisLkcd1 (cons Kcd LisLkcd1))
(mapcar
'(lambda (Kco Kc)
(setq
Kcdo (+ Kcdo (nth n1 LisLkco)) LisLkcdo (cons Kcdo LisLkcdo)
Kcd (+ Kcd (nth n1 LisLkc)) LisLkcd1 (cons Kcd LisLkcd1)
Kcd1 (+ Kcd1 (nth n1 LisLkc)) LisLkcd (cons Kcd1 LisLkcd)
n1 (1+ n1)
)
);endlambda
LisLkco LisLkc
);endmapcar
(setq LisLkcdo (reverse LisLkcdo) LisLkcd1 (reverse LisLkcd1) LisLkcd (reverse LisLkcd))
;----------------------------------------
;mapcar deltaMD deltaDO
(setq n2 1
n3 0
LisHo (cons Ho LisHo)
Cdo (- (nth 0 Lismd) Ho) Lisdo (cons Cdo Lisdo)
DeltaMD (* (- (nth 0 Lismd) Ess) Td) DeltaDO (* (- (nth 0 Lismd) Ess Ho) Td)
LisDeltaMD (cons DeltaMD LisDeltaMD) LisDeltaDo (cons DeltaDo LisDeltaDo))
(mapcar
'(lambda (Cmd io1 Kco)
(setq
Cdo (- Cdo (* Kco (nth n3 Lisi))) Lisdo (cons Cdo Lisdo)
Ho (- (nth n2 Lismd) Cdo) LisHo (cons Ho LisHo)
DeltaMD (* (- (nth n2 Lismd) Ess) Td) LisDeltaMD (cons DeltaMD LisDeltaMD)
DeltaDO (- deltaDO (* (nth n3 LisLkco) (nth n3 Lisi) Td))
LisDeltaDO (cons DeltaDO LisDeltaDO)
n2 (1+ n2)
n3 (1+ n3)
)
);endlambda
Lismd Lisi LisLkco
);endmapcar
(setq LisDeltaMD (reverse LisDeltaMD) LisDeltaDO (reverse LisDeltaDO)
LisHo (reverse LisHo) Lisdo (reverse Lisdo))
;-------------------------------------------
;data cornor.
(repeat k
(progn
(print (nth 3 LisTs)) (prin1 CTc) (prin1 i3)
(setq
Gmb (getreal "\nGoc quay mat bang :")
LisGoc (cons Gmb LisGoc)
i3 (1+ i3)
)
);endprogn
);endrepeat;(princ Lis)
(setq LisGoc (reverse LisGoc))
;-------------------------------------------
(Repeat 8
(setq Ptb (polar Pta a (* i 10))
Ptc (polar Pta1 a (* i 10))
ptd (polar pta2 a (+ (* i 10) 3.5))
)
(command
"layer" "s" "manh" ""
"line" Ptb Ptc ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "ml" ptd 2.5 0.0 (nth (+ (* i 2) 1) LisCSS)
)
(setq i (+ i 1))
);endrepeat
(command
"layer" "s" "manh" ""
"line" Pta Ptb ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" "" ""
"text" "j" "ml" Pta5 2.5 0.0 (strcat "TYÛ LEÄ NGANG: 1/" (rtos Tln))
"text" "j" "ml" Pta6 2.5 0.0 (strcat "TYÛ LEÄ ÑÖÙNG: 1/" (rtos Tld))
;------------------------
(COCSS)
;draw one
(setq LisPTcoc nil PTcoc (polar Pta1 a 5) LisPTcoc (cons PTcoc LisPTcoc)
LisPGmb nil PGmb (polar Ptss1 a 15) LisPGmb (cons PGmb LisPGmb)
LisPGmb nil PGmb (polar Ptsg1 a 17) LisPGmb (cons PGmb LisPGmb)
LisPGmb1 nil PGmb1 (polar Pta1 a 13) LisPGmb1 (cons PGmb1 LisPGmb1)
LisPKc nil PKc (polar Pta1 a 25) LisPKc (cons PKc LisPKc)
LisPdd nil Pdd (polar Pta1 a 30) LisPdd (cons Pdd LisPdd)
Pddi (polar pta1 a 30)
LisPho nil Pho (polar Pta1 a 45) LisPho (cons Pho LisPho)
LisPmd nil Pmd (polar Pta1 a 65) LisPmd (cons Pmd LisPmd)
LisPdo nil Pdo (polar Pta1 a 55) LisPdo (cons Pdo LisPdo)
LisPss nil Pss (polar Pta1 a 70) LisPss (cons Pss LisPss)
LisPsg nil Psg (polar Pta1 a 15) LisPsg (cons Psg LisPsg)
LisPssd nil LisPssd1 nil LisPssdo nil LisPssdo1 nil
V 0
)
(mapcar
'(lambda (Kc)
(setq
PTcoc (polar PTcoc 0 (nth V LisLkc)) LisPTcoc (cons PTcoc LisPTcoc)
PGmb (polar PGmb 0 (nth V LisLkc)) LisPGmb (cons PGmb LisPGmb)
PGmb1 (polar PGmb1 0 (nth V LisLkc)) LisPGmb1 (cons PGmb1 LisPGmb1)
PKc (polar PKc 0 (nth V LisLkc)) LisPKc (cons PKc LisPKc)
Pdd (polar Pdd 0 (nth V LisLkc)) LisPdd (cons Pdd LisPdd)
Pho (polar Pho 0 (nth V LisLkc)) LisPho (cons Pho LisPho)
Pmd (polar Pmd 0 (nth V LisLkc)) LisPmd (cons Pmd LisPmd)
Pdo (polar Pdo 0 (nth V LisLkc)) LisPdo (cons Pdo LisPdo)
Pss (polar Pss 0 (nth V LisLkc)) LisPss (cons Pss LisPss)
V (1+ V)
)
)
LisLkc
)
(setq LisPTcoc (reverse LisPTcoc)
LisPGmb (reverse LisPGmb) LisPGmb1 (reverse LisPGmb1)
LisPKc (reverse LisPKc)
LisPdd (reverse LisPdd)
LisPHo (reverse LisPHo) LisPmd (reverse LisPmd) LisPdo (reverse LisPdo)
LisPss (reverse LisPss)
V1 0)
;-----------
(mapcar
'(lambda (PTcoc PGmb PGmb1 PKc Pho Pmd Pdo Pss
Tcoc Gmb Kcdo Ho Cmd Cdo deltaMD deltaDO)
(setq
;parameter draw rotational corner
PGmb11 (polar PGmb1 0 -3.5) PGmb14 (polar PGmb1 0 3.5)
PGmb12 (polar PGmb1 a 2) PGmb122 (polar PGmb12 0 -3.5) PGmb13 (polar PGmb12 0 3.5);90
PGmb133 (polar PGmb13 a 2.5) PGmb144 (polar PGmb13 a 4.5)
PGmb2 (polar PGmb1 a 2) PGmb21 (polar PGmb2 0 -3.5);PGmb22 (polar PGmb2 a45 4.5) PGmb23 (polar PGmb2 a45 6.5);PGmb24 (polar PGmb2 0 3.5) PGmb25 (polar PGmb2 0 6);=180
PGmb26 (polar PGmb2 b45 4) PGmb27 (polar PGmb2 b45 6.5);>180
PGmb3 (polar PGmb1 a 2) PGmb31 (polar PGmb3 0 -3.5) PGmb32 (polar PGmb3 0 3.5);270
PGmb33 (polar PGmb32 c 2.5) PGmb34 (polar PGmb32 c 4.5)
;end draw rotational corner
;parameter comparation
Pssd (polar Pss a (nth V1 LisDeltaMD)) LisPssd (cons Pssd LisPssd)
Pssdo (polar Pss a (nth V1 LisDeltaDO)) LisPssdo (cons Pssdo LisPssdo))
(command
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "mc" PTcoc 4.5 0.0 (strcat CTc (itoa (nth V1 LisTcoc)))
"text" "j" "mc" PKc 2.2 90.0 (rtos (nth V1 LisLkcdo) 2 2)
"text" "j" "mc" Pho 2.2 90.0 (rtos (nth V1 LisHo) 2 2)
"text" "j" "mc" Pmd 2.2 90.0 (rtos (nth V1 Lismd) 2 2)
"text" "j" "mc" Pdo 2.2 90.0 (rtos (nth V1 Lisdo) 2 2)
"layer" "s" "chua" ""
"style" "chua" "romans.shx" "" "0.7" "" "" "" ""
"text" "j" "mc" PGmb 2.0 0.0 (strcat (rtos (nth V1 LisGoc) 2 0) "%%d")
"layer" "s" "bao" ""
"circle" PTcoc "5"
"layer" "s" "giong" ""
"line" Pss Pssd ""
"layer" "s" "manh" "")
(cond
((= Gmb 90) (command "pline" PGmb122 PGmb13 PGmb133 "w" "1.0" "0" PGmb144 ""))
((((= Gmb 180) (command "pline" PGmb21 PGmb24 "w" "1.0" "0" PGmb25 ""))
((or (and (> Gmb 180) ( Gmb 270) ((command "pline" PGmb21 PGmb2 PGmb26 "w" "1.0" "0" PGmb27 ""))
((= Gmb 270) (command "pline" PGmb31 PGmb32 PGmb33 "w" "1.0" "0" PGmb34 ""))
)
(setq V1 (1+ V1))
);endlambda
LisPTcoc LisPGmb LisPGmb1 LisPKc LisPho LisPmd LisPdo LisPss
LisTcoc LisGoc LisLkcdo LisHo Lismd Lisdo LisdeltaMD LisdeltaDO
);endmapcar (princ lis)
;-----
;draw two
(setq lisdd (cdr LisLkcd)
Pdd1 (polar Pddi a 3.5) Pdd2 (polar Pddi a 6.5) Pdd3 (polar Pddi a 10)
Pdd4 (polar Pddi a 5)
PKcd (polar Pta1 a 25)
)
(command "layer" "s" "manh" "" "line" pddi pdd3 "")
(setq V4 0)
(repeat (length Lisdd)
(setq
;parameter gradient
Pddi1 (polar Pddi 0 (- (nth V4 Lisdd) (nth V4 LisLkc)))
Pddi2 (polar Pdd3 0 (- (nth V4 Lisdd) (nth V4 LisLkc)))
Pddi3 (polar Pdd4 0 (- (nth V4 Lisdd) (nth V4 LisLkc)))
Pdd11 (polar Pdd1 0 (- (nth V4 Lisdd) (- (nth V4 LisLkc) 10)))
Pdd12 (polar Pdd1 0 (- (nth V4 Lisdd) 10))
Pdd21 (polar Pdd2 0 (- (nth V4 Lisdd) (- (nth V4 LisLkc) 10)))
Pdd22 (polar Pdd2 0 (- (nth V4 Lisdd) 10))
Pdd31 (polar Pdd3 0 (nth V4 Lisdd))
Pdd32 (polar Pddi 0 (nth V4 Lisdd))
Pdd41 (polar Pdd4 0 (nth V4 Lisdd))
PKcd1 (polar PKcd 0 (- (nth V4 Lisdd) (/ (nth V4 LisLkc) 2)))
)
(cond
((> (nth V4 Lisi) 0)
(command
"layer" "s" "manh" ""
"pline" Pddi2 Pdd32 Pdd31 ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "mc" PKcd1 2.5 0.0 (strcat (rtos (nth V4 LisLkco) 2 2) "m" )
"text" "j" "mc" Pdd11 2.5 0.0 (strcat (nth VL LisVL) " - " "D" (rtos D 2 0))
"text" "j" "mc" Pdd22 2.5 0.0 (strcat "i=" (rtos (nth V4 Lisi) 2 4))))
((= (nth V4 Lisi) 0)
(command
"layer" "s" "manh" ""
"pline" Pddi3 Pdd41 Pdd31 Pdd32 ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "mc" PKcd1 2.5 0.0 (strcat (rtos (nth V4 LisLkco) 2 2) "m" )
"text" "j" "mc" Pdd11 2.5 0.0 (strcat (nth VL LisVL) " - " "D" (rtos D 2 0))
"text" "j" "mc" Pdd22 2.5 0.0 (strcat "i=" (rtos (nth V4 Lisi) 2 4))))
(((command
"layer" "s" "manh" ""
"pline" Pddi1 Pdd31 Pdd32 ""
"layer" "s" "chuv" ""
"style" "chuv" "VNI-Helve-condense" "" "1" "" "" ""
"text" "j" "mc" PKcd1 2.5 0.0 (strcat (rtos (nth V4 LisLkco) 2 2) "m" )
"text" "j" "mc" Pdd12 2.5 0.0 (strcat (nth VL LisVL) " - " "D" (rtos D 2 0))
"text" "j" "mc" Pdd21 2.5 0.0 (strcat "i=" (rtos (nth V4 Lisi) 2 4))))
)
(setq V4 (1+ V4))
)
;--draws ground and pipe bottom level line
(setq
LisPssd (reverse LisPssd)
LisPssd1 (append (cdr LisPssd) (car LisPssd))
LisPssdo (reverse LisPssdo)
LisPssdo1 (append (cdr LisPssdo) (car LisPssdo))
V2 0 V3 0
)
;;;;;;doan nay di chuyen len cho chay truoc;;;;;;;;;;;;;;;;;
(repeat 8
(setq Ptdao (polar Pta1 a 70)
Ptda1 (polar Ptdao c (* V3 10))
Ptda2 (polar Pss c (* V3 10)))
(command "layer" "s" "manh" "" "line" Ptda1 Ptda2 "")
(setq V3 (1+ V3))
);repeat;;;;;;;;;;;;;ket thuc doan di chuyen len cho chay truoc;;;;;;;;;;;;;;;;;;;;;
(repeat (- (length LisPssd) 1)
    (setq gocxeoa(angle (nth V2 LisPssdo)  (nth V2 LisPssdo1)));;;;;;;;;duy viet them ;;;;;;;;;;;;;;;
    (setq a (polar (nth V2 LisPssdo) (+ (/ pi 2) gocxeoa) kcong));;;;;;;;;duy viet them ;;;;;;;;;;;;;;;
    (setq b (polar (nth V2 LisPssdo1) (+ (/ pi 2) gocxeoa) kcong));;;;;;;;;duy viet them ;;;;;;;;;;;;;;;
(command
"layer" "s" "manh" ""
"line" (nth V2 LisPssd) (nth V2 LisPssd1) ""
"layer" "s" "ong" ""
"line" (nth V2 LisPssdo) (nth V2 LisPssdo1) ""
"line" a b "";;;;;;;;;duy viet them ;;;;;;;;;;;;;;;
)
(chenkyhieudat)   ;;;;;;;;;duy viet them ;;;;;;;;;;;;;;;
(setq V2 (1+ V2))
)

;--end draws ground and pipe bottom level line
(onap2)
);progn
);end function STD
;--------------------
;;;;;;;;;;;;;;duy viet them phan chen ky hieu dat;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun chenkyhieudat ()
    (setq  daiab(distance (nth V2 LisPssd)  (nth V2 LisPssd1)))  
    (setq gocxeo(angle (nth V2 LisPssd)  (nth V2 LisPssd1)))
    (setq solan (- (fix (/ daiab 30)) 1))
    (setq c (polar (nth V2 LisPssd) gocxeo 30))
(command "layer" "s" "dat" "")
(command ".INSERT" "ky hieu dat 5" (nth V2 LisPssd) 1 1 (nth V2 LisPssd1))
(repeat solan
(command "copy" "last" "" (nth V2 LisPssd) c "")
)
);;;;;;;;;;;;;;ket thuc phan duy viet them;;;;;;;;;;;;;;;;;;;;;;

Chào bạn HoangSon 614,

Thực tình mình cũng chưa hiểu ý bạn muốn hỏi.

Nếu là bạn chỉ muốn thay đổi cách nhập các biến Tld và Tln trong lisp bạn post . còn các phần khác giữ nguyên thì bạn hãy chú ý các điều sau đây:

1/- Đoạn code:

(setq

Tln (getint "\nTy le ngang 1/x (100, 200, 500, 1000); x="))

Tld (getint "\nTy le dung 1/y (100, 200); y="))

Tn (/ 1000.0 Tln)

Td (/ 1000.0 Tld)

)

sử dụng hàm (getint ......) nó yêu cầu bạn nhập một dữ liệu dạng số nguyên và trả về giá trị của các biến tld và tln là các số nguyên. Sau đó lisp dùng giá trị này để tính toán các giá trị của các biến tn và td.

2/- Đoạn bạn đã viết:

"text" "j" "ml" Pta5 2.5 0.0 ((strcat "TYÛ LEÄ NGANG: 1/" (rtos Tln))

"text" "j" "ml" Pta6 2.5 0.0 (strcat "TYÛ LEÄ ÑÖÙNG: 1/" (rtos Tld))

thực ra chưa phải là code lisp vì tất cả các hàm lisp đều phải bắt đầu từ dấu mở ngoặc đơn "(" bạn ạ và thừa một dấu ngoặc mở ở hàm strcat như bác Giabach đã nói.

Nếu bạn sửa thành:

(command "text" "j" "ml" Pta5 2.5 0.0 (strcat "TYÛ LEÄ NGANG: 1/" (rtos Tln)))

Thì đây là một đoạn lisp dùng để viết một đoạn text lên bản vẽ của bạn với điều kiện biến tln là một số đã biết rồi trả về giá trị nil chứ chả có biến tn ở đâu cả.

Nếu bạn viết:

(setq tn (command "text" "j" "ml" Pta5 2.5 0.0 (strcat "TYÛ LEÄ NGANG: 1/" (rtos Tln))))

Thì đoạn lisp này sẽ viết một text lên bản vẽ của bạn với điều kiện biến tln là một giá trị số đã biết và trả về giá trị của biến tn là nil vì hàm command chỉ thực hiện một lệnh trong cad rồi trả về nil chứ không trả về một giá trị của biến.

Nếu bạn viết:

(setq tn (Strcat "TY LE NGANG: 1/" (rtos tln)))

thì đoạn lisp này sẽ trả về giá trị của biến tn là một chuỗi chứ không phải một số bạn ạ và như vậy vẫn phải xác định biến tln là một giá trị số trước đó cơ.

Tất cả những đoạn lisp trên đều không thể thay thế đoạn lisp cũ vì chương trình của bạn vẫn còn sử dụng các biến tn, td, tln, tld cho các mục đích tính toán ở các phần khác nữa bạn ạ.

3/- Nếu bạn không quan tâm tới các biền tn, td và bạn không sử dụng các biến tln, tld vào các phần sau của chương trình mà muốn gán biến tld và tln ở dạng chuỗi thì bạn có thể dùng như sau:

(setq tln (strcat "TY LE NGANG: 1/" (getstring "Nhap gia tri ty le")))

Bạn hãy đọc kỹ bài trả lời của mình và chọn lấy cái bạn cần nha.

Chúc bạn thành công.

Download lisp

Filename: 74888_std.lsp

Tác giả: thanhduan2407
Bài viết gốc: 443950
Tên lệnh: 00

đo khoảng cách từ đoạn thẳng 1 kéo dài đến đoạn thẳng 2

Mình viết hơi dài nhưng tạm dùng

(defun C:00 (/ A DELTA LTSINTERS LTSSORT OBJKHUNG OBJLINE P1 P1A P1B P2	P2A P2B	PMID S1	S2 VBADIM )
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	ObjKhung
	...
>>

Mình viết hơi dài nhưng tạm dùng

(defun C:00 (/ A DELTA LTSINTERS LTSSORT OBJKHUNG OBJLINE P1 P1A P1B P2	P2A P2B	PMID S1	S2 VBADIM )
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	ObjKhung
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn khung: "
	     (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x))))))
	     entsel
	     nil
	   )
	 )
  )
  (setq	ObjLine
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn Line: "
	     (lambda (x) (eq "LINE" (cdr (assoc 0 (entget (car x))))))
	     entsel
	     nil
	   )
	 )
  )
  (setq	Delta (LM:GetXWithDefault
		getdist
		"\nNh\U+1EADp s\U+1ED1 b\U+1ECB tr\U+1EEB: "
		'*Delta*
		5.0
	      )
  )
  (setq P1A (cdr (assoc 10 (entget ObjLine))))
  (setq P2A (cdr (assoc 11 (entget ObjLine))))
  (setq	LtsInters (LM:Intersections
		    (vlax-ename->vla-object ObjLine)
		    (vlax-ename->vla-object ObjKhung)
		    acextendthisentity
		  )
  )
  (setq LtsSort (SortAB (append LtsInters (list P1A P2A))))
  (if (< (vl-position P1A LtsSort) (vl-position P2A LtsSort))
    (progn
      (setq P1 P1A)
      (setq P2 P2A)
    )
    (progn
      (setq P1 P2A)
      (setq P2 P1A)
    )
  )
  (if (/= (vl-position P1 LtsSort) 0)
    (progn
      (setq P1B (nth (- (vl-position P1 LtsSort) 1) LtsSort))
      (setq P2B (nth (+ (vl-position P2 LtsSort) 1) LtsSort))
      (setq S1 (distance P1 P1B))
      (setq S2 (distance P2 P2B))
      (if (< S1 S2)
	(progn

	  (setq Pmid (mid2Pnt P1 P1B))
	  (makedimrot P1 P1B Pmid (GochuongBac P1 P1B))
	  (setq VbaDIM (vlax-ename->vla-object (entlast)))
	  (setq a (- (vla-get-Measurement VbaDIM) Delta))
	  (vla-put-TextOverride VbaDIM (rtos a 2 2))
	)
	(progn
	  (setq Pmid (mid2Pnt P2 P2B))
	  (makedimrot P2 P2B Pmid (GochuongBac P2 P2B))
	  (setq VbaDIM (vlax-ename->vla-object (entlast)))
	  (setq a (- (vla-get-Measurement VbaDIM) Delta))
	  (vla-put-TextOverride VbaDIM (rtos a 2 2))
	)
      )
    )
  )
  (setvar "OSMODE" Olmode)
  (princ)
)

(defun makedimrot (p1 p2 locpt dimang / elist)
  (setq	elist (list
		'(0 . "DIMENSION")
		'(100 . "AcDbEntity")
		(cons '8 (getvar "clayer"))
		'(100 . "AcDbDimension")
		(cons '10 locpt)
		'(11 0.0 0.0 0.0)
		'(12 0.0 0.0 0.0)
		'(70 . 32)
		'(52 . 0.0)
		'(53 . 0.0)
		'(54 . 0.0)
		'(51 . 0.0)
		'(210 0.0 0.0 1.0)
		(cons '3 (getvar "dimstyle"))
		'(100 . "AcDbAlignedDimension")
		(cons '13 p1)
		(cons '14 p2)
		(cons '50 dimang)
		'(100 . "AcDbRotatedDimension")
	      )
  )
  (entmake elist)
)

(defun mid2Pnt (p1 p2)
  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
)
(defun GochuongBac (P1 P2 / Goc)
  (setq Goc (angle P1 P2))
  (if (or (<= 0 Goc (/ pi 2))
	  (<= (/ (* 3 pi) 2) Goc (* 2 pi))
      )
    (setq GocOK Goc)
    (setq GocOK (+ Goc pi))
  )
  GocOK
)
(defun MakeText
		(point string Height Ang justify Layer Style Color / Lst)
							    ; Ang: Radial
  (setq	Lst	(list '(0 . "TEXT")
		      (cons 10 point)
		      (cons 40 Height)
		      (cons 8
			    (if	Layer
			      Layer
			      (getvar "CLAYER")
			    )
		      )
		      (cons 1 string)
		      (if Ang
			(cons 50 Ang)
		      )
		      (cons 7
			    (if	Style
			      Style
			      (getvar "Textstyle")
			    )
		      )
		      (cons 62
			    (if	Color
			      Color
			      256
			    )
		      )
		)
	justify	(strcase justify)
  )
  (cond
    ((= justify "C")
     (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))
    )
    ((= justify "L")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 73 0) (cons 10 point)))
     )
    )
    ((= justify "R")
     (setq Lst (append Lst (list (cons 72 2) (cons 11 point))))
    )
    ((= justify "M")
     (setq Lst (append Lst (list (cons 72 4) (cons 11 point))))
    )
    ((= justify "TL")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "TC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "TR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "ML")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "MC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "MR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "BL")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))
     )
    )
    ((= justify "BC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))
     )
    )
    ((= justify "BR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))
     )
    )
  )
  (entmakex Lst)
)
(defun SortAB (lstPnt /)
  (setq	Lts-Sort
	 (vl-sort (vl-sort lstPnt
			   '(lambda (e1 e2) (< (cadr e1) (cadr e2)))
		  )
		  '(lambda (e1 e2) (< (car e1) (car e2)))
	 )
  )
  Lts-Sort
)
(defun LM:Intersections	(obj1 obj2 mode / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
  (repeat (/ (length l) 3)
    (setq r (cons (list (car l) (cadr l) (caddr l)) r)
	  l (cdddr l)
    )
  )
  (reverse r)
)
(defun LM:SelectIf (msg pred func keyw / sel)
  (setq pred (eval pred))
  (while
    (progn
      (setvar 'ERRNO 0)
      (if keyw
	(apply 'initget keyw)
      )
      (setq sel (func msg))
      (cond
	((= 7 (getvar 'ERRNO))
	 (princ
	   "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i! H\U+00E3y ch\U+1ECDn l\U+1EA1i."
	 )
	)
	((eq 'STR (type sel))
	 nil
	)
	((vl-consp sel)
	 (if (and pred (not (pred sel)))
	   (princ "")
	 )
	)
      )
    )
  )
  sel
)
(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)

Download lisp

Filename: 443950_00.lsp

Tác giả: quansla
Bài viết gốc: 444001
Tên lệnh: t11111

(Xin lisp) Cắt đoạn thẳng theo yêu cầu.

Thiếu giữ liệu, thiếu file cad minh họa, không hiểu 20mm là gì (cad không sử dụng đơn vị đo lường chiều dài nhé) cad chỉ có đơn vị Cad thôi. Có chắc là muốn xóa đi không? xóa đi lấy gì để kiểm tra, Layer và màu sắc đối tượng sau khi hiệu chỉnh là gì, có cần xử lý với Spline + Polyline không?

Bạn cần kiểm tra lại cách đăng bài trong Forum nhé (đọc...

Bạn cần kiểm tra lại cách đăng bài trong Forum nhé (đọc nội quy lại nhé)

(defun c:t11111(/ ob p1_diemdau p2_diem_t2 p3_diem_t3 p4_diemcuoi)
  ;theo yeu cau cua cadvieter tai https://www.cadviet.com/forum/topic/179486-xin-lisp-c%E1%BA%AFt-%C4%91o%E1%BA%A1n-th%E1%BA%B3ng-theo-y%C3%AAu-c%E1%BA%A7u/
  ; yeu cau B1-quet chon cac doi tuong la LINE, thuoc Layer ?
  ; List tu chon 4 diem tren Line da chon de tao lai thanh doi tuong moi (da cat)

  ;B1: quet chon doi tuong
  (foreach dt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((-4 . "<OR")								      
								      (-4 . "<AND") (0 . "LWPOLYLINE") (90 . 2) (-4 . "AND>")
								      (0 . "LINE")
								   (-4 . "OR>")
								   ))
							  )))
    ;(setq dt (car(entsel)))
    (setq ob (vlax-ename->vla-object dt)
	  p1_diemdau (vlax-curve-getpointatdist ob 5)
	  p2_diem_t2 (vlax-curve-getpointatdist ob 25)

	  p3_diem_t3 (vlax-curve-getpointatdist ob (- (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) 25))
	  p4_diemcuoi (vlax-curve-getpointatdist ob (- (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) 5))
	  )
    (if (and p1_diemdau p2_diem_t2)
      (entmakex
	(list (cons 0 "LINE") (cons 8 "Net moi") (cons 10 p1_diemdau) (cons 11 p2_diem_t2) (cons 62 1)))
      )
    (if (and p3_diem_t3 p4_diemcuoi)
      (entmakex
	(list (cons 0 "LINE") (cons 8 "Net moi") (cons 10 p3_diem_t3) (cons 11 p4_diemcuoi) (cons 62 1)))
      )


    ;Neu muon xoa thi de lai dong nay
    ;(entdel dt)
    ;Muon xoa thi sua dong nay
    
    )
  
  (princ)
  )

Download lisp

Filename: 444001_t11111.lsp

Tác giả: 790312
Bài viết gốc: 444021
Tên lệnh: sq

Lisp chỉ đúng khi sử dụng lần đâu

Chào các bác,

E có 1 lisp để vẽ mũi tên hai đầu đoạn thẳng. Khi đánh lệnh sử dụng lần đầu thì OK, nhưng đánh lệnh lần hai để vẽ đoạn thẳng khác thì nó chỉ vẽ mũi tên cho một đầu đoạn thẳng. Mong các bác sửa lỗi này giúp. Cảm ơn rất nhiều.

(defun c:sq (/ p1 p2 lstPnt)   
  (setq lstPnt '())
  (if (not asize)...
>>

Chào các bác,

(defun c:sq (/ p1 p2 lstPnt)   
  (setq lstPnt '())
  (if (not asize) (setq asize 550))      
  (if (not PThk)  (setq PThk 0))                 
  (defun GETR (val msg / tm)
    (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
    (cond ((= (type tm) 'REAL) (eval tm))
          ((= tm nil) (eval val))
          (t (princ "\007 *error* Wrong Input Start Point") (eval val)) ) )
  (defun loop ()
    (cond ((and(setq p2 (getpoint p1 "\nNext Point : "))(setq lstPnt (append (list p2) lstPnt))) (command p2) 
                                     (setq p0 p1) (setq p1 p2) (loop))
          ( t (command "u" (polar p1 (angle p1 p0) asize)
                       "w" (/ asize 3) 0.0 p1 ""))))
  (setq asize (getr asize "\nArrowheads Size :"))
  (setq PThk  (getr PThk "\n PLine Width :"))
  (setq p1 (getpoint "\nStart Point : "))
  (setq lstPnt (append (list p1) lstPnt))
  (command "layer" "m" "S04. REMARK" "c" "6" """")
  (command "pline" p1 "w" 0.0 0.0)
  (setq p2 (getpoint p1 "\nNext Point : "))
  (setq lstPnt (append (list p2) lstPnt))
  (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
           "w" PThk PThk p2)
  (setq p1 p2)
  (loop)
(if  (ST:Geo-ListLinear lstPnt)
    (foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 125))
)
  (eval "Done")
)
(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
  (
    (lambda ( a b c )
      (or
        (equal (+ a B) c fuzz)
        (equal (+ b c) a fuzz)
        (equal (+ c a) b fuzz)
      )
    )
    (distance p1 p2) (distance p2 p3) (distance p1 p3)
  )
)
(defun ST:Geo-ListLinear (lst / tmp)
(setq i 2)
(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
        (T (while (and (< i (1- (length lst)))
                (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
                tmp
            )
        )
)
tmp
)
(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

Download lisp

Filename: 444021_sq.lsp

Tác giả: quansla
Bài viết gốc: 444019
Tên lệnh: t11111

(Xin lisp) Cắt đoạn thẳng theo yêu cầu.

cho 1 like cho @alisp

Cười

Với chủ thớt:

1. Không cần thiết phải thêm lựa chọn layer làm gì, dùng lệnh Layiso (chú ý thiết lập Fezzen gì đấy) hoặc đơn giản dùng Qslect hoặc khó hơn ý...

cho 1 like cho @alisp

Cười

Với chủ thớt:

1. Không cần thiết phải thêm lựa chọn layer làm gì, dùng lệnh Layiso (chú ý thiết lập Fezzen gì đấy) hoặc đơn giản dùng Qslect hoặc khó hơn ý dùng Fiel là được phần quét chọn toàn bộ đối tượng thuộc layer

2. Bạn có chắc muốn ẩn layer của đối tượng dài 20 đơn vị sau khi kết thúc lệnh (thử nghĩ xem nếu chạy Lisp xong mà màn hình không có hiển thị gì thay đổi thì làm sao?)

3. Muốn ẩn đối tượng có thể sử dụng Layoff rất đơn giản

4. Có chút nhầm lẫn rất rất không lên sử dụng với Spline, mà bạn làm cái gì mà có yêu cầu này vậy, bản vẽ để test có thể gửi lên không

Lisp viết lại thêm yêu cầu đổi tên layer và để màu đối tượng là màu 1 (red)

(defun c:t11111(/ ob p1_diemdau p2_diem_t2 p3_diem_t3 p4_diemcuoi)
  ;theo yeu cau cua cadvieter tai https://www.cadviet.com/forum/topic/179486-xin-lisp-c%E1%BA%AFt-%C4%91o%E1%BA%A1n-th%E1%BA%B3ng-theo-y%C3%AAu-c%E1%BA%A7u/
  ; yeu cau B1-quet chon cac doi tuong la LINE, thuoc Layer ?
  ; List tu chon 4 diem tren Line da chon de tao lai thanh doi tuong moi (da cat)

  ;B1: quet chon doi tuong
  (foreach dt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((-4 . "<OR")								      
								      (-4 . "<AND") (0 . "LWPOLYLINE") (90 . 2) (-4 . "AND>")
								      (0 . "LINE")
								      ;(0 . "SPLINE")
								   (-4 . "OR>")
								   ))
							  )))
    ;(setq dt (car(entsel)))
    (setq ob (vlax-ename->vla-object dt)
	  p1_diemdau (vlax-curve-getpointatdist ob 5)
	  p2_diem_t2 (vlax-curve-getpointatdist ob 25)

	  p3_diem_t3 (vlax-curve-getpointatdist ob (- (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) 25))
	  p4_diemcuoi (vlax-curve-getpointatdist ob (- (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) 5))
	  )


    ;(if (= (cdr(assoc 0 (entget dt))) "SPLINE")
      ;(setq p3_diem_t3 (polar p4_diemcuoi (angle p3_diem_t3 p4_diemcuoi ) 20)))
    (if (and p1_diemdau p2_diem_t2)
      (entmakex
	(list (cons 0 "LINE") (cons 8 (strcat (cdr(assoc 8 (entget dt))) "-1")) (cons 10 p1_diemdau) (cons 11 p2_diem_t2) (cons 62 1)))
      )
    (if (and p3_diem_t3 p4_diemcuoi)
      (entmakex
	(list (cons 0 "LINE") (cons 8 (strcat (cdr(assoc 8 (entget dt))) "-1")) (cons 10 p3_diem_t3) (cons 11 p4_diemcuoi) (cons 62 1)))
      )


    ;Neu muon xoa thi de lai dong nay
    ;(entdel dt)
    ;Muon xoa thi sua dong nay
    
    )
  
  (princ)
  )

Download lisp

Filename: 444019_t11111.lsp

Tác giả: dunguss3581
Bài viết gốc: 199584
Tên lệnh: ntn

Lisp xuất nhập thông tin tọa độ điểm

Vấn đề tui chưa làm được là vị trí con trỏ để ghi text tui open file với method "a" thì số liệu lại cứ ghi ra cuối file. hoặc báo lỗi. Các bác xem giúp tui xem sai cú pháp ở đâu?

(defun c:ntn ( / fn fid strht vt x y z)
  (defun pos (sub st / l1 l2 index)
(setq index 1
  l1 (strlen sub)
  l2 (strlen st)
)
(while
 	(and...
>>

(defun c:ntn ( / fn fid strht vt x y z)
  (defun pos (sub st / l1 l2 index)
(setq index 1
  l1 (strlen sub)
  l2 (strlen st)
)
(while
 	(and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
  	(setq index (1+ index))
)
(if (= sub (substr st index l1))
 	index
 	nil
)
 )
 
 (princ "vvvvvvvvvvvvvvvvvvvv")
 (setq fn  (getfiled "Chon tep ntd can nhap TN" (getvar "dwgprefix") "txt" 1))
 (setq fid (open fn "a"))
  (setq tencoc(getstring "\n nhap ten coc:"))
 (while (setq strht (read-line fid))
(setq strht (strcat strht "\t\t\t\t"))
(if (/= strht "   ")
 	(progn
(setq
  vt (pos "\t" strht)
  mot (substr strht 1 (1- vt))
  strht (substr strht (1+ vt))

  vt (pos "\t" strht)
  hai (substr strht 1 (1- vt))
  strht (substr strht (1+ vt))

  vt (pos "\t" strht)
  ba (substr strht 1 (1- vt))
  strht (substr strht (1+ vt))
   vt (pos "\t" strht)
  bon (substr strht 1 (1- vt))
  strht (substr strht (1+ vt))
)
 	);het progn
); het if
(princ "da lam den day")
(if (and (= mot "POLE") (= tencoc hai))
 	(progn
 (princ "\nda lam den day nua")
 (write-line "da tim duoc coc" fid)
)
 	)
 )
 (close fid)
)

Download lisp

Filename: 199584_ntn.lsp

Tác giả: dovananh.xd
Bài viết gốc: 173203
Tên lệnh: sct

Sửa Lisp xoay thành scale đối tượng tại tâm

Tue_NV đã góp ý với bạn tại sao bạn không nghe? Bạn khiến cho Tue_NV không vui rồi đấy

Mở rộng với mọi...
>>
Tue_NV đã góp ý với bạn tại sao bạn không nghe? Bạn khiến cho Tue_NV không vui rồi đấy

Mở rộng với mọi đối tượng thì tâm được định nghĩa như thế nào ???

Đây là code scale n đường tròn tại tâm của đường tròn
(defun c:SCT(/ ci tl n i)
(prompt "\n Moi ban chon CIRCLE")
(setq ci (ssget '((0 . "CIRCLE"))))
(setq tl (getreal "\n Nhap ti le scale :") n (sslength ci) i 0)

(while (< i n)
(setq ent (ssname ci i))
(command "scale" ent "" (cdr(assoc 10 (entget ent))) tl)
(setq i (1+ i))
)
(princ)
)
Thanks!

Lisp này cực hay. Bác có thể phát triển lisp này để có thể scale các đối tượng như Donut, Block không ạ?

<<

Download lisp

Filename: 173203_sct.lsp

Tác giả: MTRUNGTDH
Bài viết gốc: 77679
Tên lệnh: cong tru nhan chia

Viết lisp theo yêu cầu [phần 2]

Mình đã nhiều lần gặp trường hợp như bạn trong công việc. đây là lisp mình tìm được trên diễn đàn này. mình đã sửa lại 1 chút để bạn có thể sử dụng...
>>
Mình đã nhiều lần gặp trường hợp như bạn trong công việc. đây là lisp mình tìm được trên diễn đàn này. mình đã sửa lại 1 chút để bạn có thể sử dụng được cả 4 phép tính. Nó có tác dụng cộng, hoặc trừ, hoặc nhân, hoặc chia tất cả các text số mà bạn chọn với một số mà bạn nhập vào.
lệnh là: cong; tru; nhan; chia.
(defun c:cong()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so muon cong them: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (+ cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:tru()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so tru: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (- cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:nhan()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so muon nhan: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (* cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:chia()
(setq i 0 s1 0)
(setq n (getreal "\nnhap mau so: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (/ cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
Chú ý là kết quả tính toán sẽ lấy số chữ số sau dấu phẩy theo Precision trong định dạng Units bản vẽ của bạn. Với text cao độ thường lấy 2 chữ số sau dấu phẩy. bạn nên thiết lập lại Precision trước khi chạy thực hiện lệnh.
Không biết sao mà mình sử dụng lisp này nó kông hiểu, dòng lệnh command vẩn chạy bình thường nhưng kô cho ra kết quả, nhờ bạn kiểm tra lại và chỉ giúp mình với. Thanks!

<<

Download lisp

Filename: 77679_cong_tru_nhan_chia.lsp

Tác giả: Tue_NV
Bài viết gốc: 56326
Tên lệnh: btd

Viết Lisp theo yêu cầu

Hi all !
Mình đang cần lisp check snap cho text nho cac ban giup

Cụ thể như sau : + Text để ở chế độ Middle center bắt snap vào Line...
>>
Hi all !
Mình đang cần lisp check snap cho text nho cac ban giup

Cụ thể như sau : + Text để ở chế độ Middle center bắt snap vào Line center

Nếu vị trí nào chưa snap lisp sẽ báo lỗi bằng Point

Ảnh minh hoạ :

File demo :http://www.cadviet.com/upfiles/textsnap_1.jpg

Bạn dùng thử đoạn Code này xem sao nhé :

(defun c:btd() (setvar "Pdmode" 2) (setvar "Pdsize" 200) (Command "undo" "BEgin") (vl-load-com) (setq curve (car(entsel "\n Chon duong :"))) (while (null curve) (setq curve (car(entsel "\n Chon lai duong :")))) (prompt "\n Chon Text : ") (setq ss (ssget '((0 . "TEXT")))) (Command "justifytext" ss "" "MC") (setq n (sslength ss) i 0) (while ((setq sn (ssname ss i)) (setq ent (entget sn)) (setq po1 (cdr(assoc 11 ent))) (setq po2 (vlax-curve-getClosestPointTo curve po1)) (setq dis (distance po1 po2)) (if (/= dis 0) (Command "point" po1)) (setq i (1+ i)) ) (setvar "Pdmode" 0) (Command "undo" "END") (Princ) )

Chúc thành công :cheers:

<<

Download lisp
Filename: 56326_btd.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 444075
Tên lệnh: ha

Lips gõ số thứ tự thì in ra tên người theo danh sách

Bạn có thể thêm tương ứng vào các dòng đang để trống


(defun C:HA(/ lst ten n)
 (setq lst
   (list 
   '(1 . "A")
   '(2 . "B")
   '(3 . "C")
   
   ))
  (setq n (getint "\nNhap 1 so nguyen: "))
  (if (setq ten (cdr (assoc n lst)))
   (alert ten)
   (alert "Chua co ten")))

Download lisp

Filename: 444075_ha.lsp

Tác giả: vantuan18nd
Bài viết gốc: 187911
Tên lệnh: tl3

Tính cao độ một điểm bất kỳ khi có cao độ cho trước

Dựa vào code đã viết cho bạn trước đó, Tue_NV viết quick code cho bạn.

Cách thức sử dụng tương tự như code mà Tue_NV viết cho bạn...
>>
Dựa vào code đã viết cho bạn trước đó, Tue_NV viết quick code cho bạn.

Cách thức sử dụng tương tự như code mà Tue_NV viết cho bạn trước đó và đương nhiên là theo yêu cầu của bạn

Chúc vui
(defun C:TL3( / ss L te p1 p2 textmau P)
(initget "P")
(setq cdd (getreal "\nNhap cao do dau hoac go P de chon Text cao do dau :"))
(if (= cdd "P")
  (setq cdd (atof (cdr(assoc 1 (entget(car(entsel "\n Pick chon Text cao do dau :")))))))
)

(setq p1 (getpoint "\n Chon diem thu nhat :"))

(while (setq p2 (getpoint p1 "\n Chon diem thu hai :"))
(setq L (+ cdd (- (cadr p2) (cadr p1))))

   (initget "T")
   (setq p (getpoint "\nPick diem chen Text hoac go T de chon Text :"))

  (if (/= p "T")
	(progn
  	(if (not textmau) (setq textmau (car(entsel "\nChon Text mau:"))))
    	(entmake (list (cons 0 "TEXT") (cons 1 (rtos L 2 2)) (assoc 40 (entget textmau))
             (cons 10 p) (cons 11 p) (assoc 7 (entget textmau))
(assoc 8 (entget textmau))
    	))
  )
     (progn
  (setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
     )
  )
);while
(princ)
)
Cảm ơn rất nhiều .

<<