Visual Lisp :

(defun c:tkd(/ lstval stp lst pw)
(setq stp 2) ;Dong nay quy dinh so le muon in ra
(cond ((ssget (list (cons 0 "DIMENSION")))
(defun dimval (e / a)(if (= (setq a(vla-get-TextOverride e)) "")
(rtos (vla-get-Measurement e) 2 stp)
(rtos (distof a) 2 stp)))
(vlax-for dObj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
(if (not (assoc (setq b (dimval dObj)) lst))

>>

Visual Lisp :

(defun c:tkd(/ lstval stp lst pw)
(setq stp 2) ;Dong nay quy dinh so le muon in ra
(cond ((ssget (list (cons 0 "DIMENSION")))
(defun dimval (e / a)(if (= (setq a(vla-get-TextOverride e)) "")
(rtos (vla-get-Measurement e) 2 stp)
(rtos (distof a) 2 stp)))
(vlax-for dObj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
(if (not (assoc (setq b (dimval dObj)) lst))
(setq lst (cons (cons b 1) lst))
(setq lst (subst (cons b (1+ (cdr (assoc b lst))))(assoc b lst) lst))
)
)
(setq pw (open (getfiled "Chon file de xuat ket qua" "" "xls" 1) "w"))
(write-line (strcat "Chieu dai" "\t" "So luong") pw)
(mapcar '(lambda(x)(write-line (strcat (car x) (chr 9) (itoa (cdr x))) pw)) lst)
(close pw)
)
)
)

Thế mới khó lường. Ngắn gọn và xúc tích Trong khi đáng ra chỉ cần 1 dòng miêu tả, cũng chẳng cần file bạn ạ


(defun c:test() (+ (distance (setq a (getpoint "\nA :")) (getpoint a...

Thế mới khó lường. Ngắn gọn và xúc tích Trong khi đáng ra chỉ cần 1 dòng miêu tả, cũng chẳng cần file bạn ạ


(defun c:test() (+ (distance (setq a (getpoint "\nA :")) (getpoint a "\nB:"))(distance (setq c(getpoint "\nC:")) (getpoint c "\nD:"))))

K được là k đc thế nào ?
Mình chỉ thấy nó tự quy định ký tự đầu là dấu " ", cò chẳng thấy k được chỗ nào. Chủ đề đã trả lời cách đây 9 ngày, chả hiểu bạn có cần thật hay thích thì hỏi

(defun c:test()(vl-load-com)
(vla-addmtext (vla-get-block (vla-get-activelayout(vla-get-activedocument (vlax-get-acad-object))))
(vlax-3d-point (getpoint "\nDiem chen Field"))
...

K được là k đc thế nào ?
Mình chỉ thấy nó tự quy định ký tự đầu là dấu " ", cò chẳng thấy k được chỗ nào. Chủ đề đã trả lời cách đây 9 ngày, chả hiểu bạn có cần thật hay thích thì hỏi

(defun c:test()(vl-load-com)
(vla-addmtext (vla-get-block (vla-get-activelayout(vla-get-activedocument (vlax-get-acad-object))))
(vlax-3d-point (getpoint "\nDiem chen Field"))
1
(strcat "%<$(substr, $(getvar, dwgname)," (itoa (1+ (setq a (getint "\nBat dau tu so:")))) "," (itoa (getint "\nSo ky tu :")) ")>%")
))

Nói luôn là diễn đàn k đồng tình việc tạo 2 hoặc nhiều nick để hút máu mọi người đâu. Bạn có thắc mắc thì cứ hỏi, ai cũng hỏi cả mà, không việc chi phải thay tên đổi nick bạn ạ

Bình thường, layer Defpoints không thể xóa được. Tuy nhiên trong một số trường hợp vẫn nảy sinh nhu cầu xóa cái layer này. Hôm trước em phát hiện ra là để xóa layer này, cần phải làm:

1. Xóa hết các dimension
2. Purge các block có dạng: *D1, *D2,...
3. Đổi tên layer Defpoints thành tên khác, ví dụ : deletelayer
4. Purge layer deletelayer này là xong

Vì phải thực hiện nhiều...

Bình thường, layer Defpoints không thể xóa được. Tuy nhiên trong một số trường hợp vẫn nảy sinh nhu cầu xóa cái layer này. Hôm trước em phát hiện ra là để xóa layer này, cần phải làm:

1. Xóa hết các dimension
2. Purge các block có dạng: *D1, *D2,...
3. Đổi tên layer Defpoints thành tên khác, ví dụ : deletelayer
4. Purge layer deletelayer này là xong

Vì phải thực hiện nhiều lần, nên em đã viết lisp sau. Share lên đây cho cả nhà, ai thấy lisp chưa ổn chỗ nào thì mong bớt chút thời gian cho em ý kiến với:


;;; Written by pdle
(defun c:bst()
(setq lb (list (cdr (assoc 2 (tblnext "block" T))))) ; Reset cho tblnext chay tu dau bang block
(while (and(not (member (setq vbl(cdr (assoc 2 (tblnext "block")))) lb)) vbl)
(setq lb (cons vbl lb))
) ; Lay het ten cac block
(setq sd (ssget "_X" (list (cons 0 "DIMENSION"))))
(if sd
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex sd)))
(entdel ent)
)
) ; Xoa het dimension
(foreach ent lb
(if (=(substr ent 1 2) "*D") (command "-purge" "b" ent "y" "y"))
) ; Purge cac block dang *D
(if (tblsearch "layer" "Defpoints")
(progn
(command "-rename" "la" "Defpoints" "deletelayer")
(command "-purge" "la" "deletelayer" "y" "y")
)
) ; Doi ten cho Defpoints va xoa no
)


Em có 2 câu hỏi sau:

1) Trong trường hợp command của CAD không thực hiện được lệnh, chẳng hạn lệnh purge không purge được block, thì làm thế nào để có thể kiểm soát bằng lisp

2) Các block dạng *E1, *E2 là liên quan đến gì trong CAD (chẳng hạn *D1, *D2,... thì liên quan đến Dimension)

Nhờ code trên cadviet, nên nó như thế này:

(defun c:pp (/ text)
(SetClipBoardText (vl-string-translate "\\" "/" (getvar 'dwgprefix)))
)
(defun SetClipBoardText (text / htmlfile result ) ; By XShrimp
(if (= 'STR (type text))
(progn
(setq htmlfile (vlax-create-object "htmlfile")
result (vlax-invoke (vlax-get (vlax-get htmlfile 'ParentWindow ) 'ClipBoardData) 'SetData "Text" text ) )

>>

Nhờ code trên cadviet, nên nó như thế này:

(defun c:pp (/ text)
(SetClipBoardText (vl-string-translate "\\" "/" (getvar 'dwgprefix)))
)
(defun SetClipBoardText (text / htmlfile result ) ; By XShrimp
(if (= 'STR (type text))
(progn
(setq htmlfile (vlax-create-object "htmlfile")
result (vlax-invoke (vlax-get (vlax-get htmlfile 'ParentWindow ) 'ClipBoardData) 'SetData "Text" text ) )
(vlax-release-object htmlfile)
text
))
)

em hay dùng tắt, bật layer khi vẽ. em cần giúp gộp đoạn code dưới đây thành 1 lệnh tắt hay bật Layer đều bằng 1 lệnh.
VD: bấm số 1 lúc đầu là tắt Layer, sau muốn hiện Layer lên lại thì lại bấm số 1 là nó hiện lại nhưng Layer đã tắt. cảm ơn các anh rất nhiều.

(defun c:1() (prompt "\nGO SO 1: DE TAT TUNG LAYER TUY CHON")(c:LAYOFF))
(defun c:11() (prompt "\nGO SO 2: DE MO TAT CA...

em hay dùng tắt, bật layer khi vẽ. em cần giúp gộp đoạn code dưới đây thành 1 lệnh tắt hay bật Layer đều bằng 1 lệnh.
VD: bấm số 1 lúc đầu là tắt Layer, sau muốn hiện Layer lên lại thì lại bấm số 1 là nó hiện lại nhưng Layer đã tắt. cảm ơn các anh rất nhiều.

(defun c:1() (prompt "\nGO SO 1: DE TAT TUNG LAYER TUY CHON")(c:LAYOFF))
(defun c:11() (prompt "\nGO SO 2: DE MO TAT CA CAC LAYER DA TAT")(c:LAYON))

Lisp tính cao độ của mình khi tính xong thì các cao độ tìm được luôn nằm lệch sang bên trái điểm cần tìm.
Mình nhờ các bạn sửa lại cho mình : sao cho các số cao độ tìm được có điểm cần tìm làm trung tâm.


(defun c:h1 ( / pt p1 p01 p02 ent ecopy elev elev1 offset etype txth)
(setvar "osmode" 1)
(command "ucs" "w")
(setq pt (getpoint "\nChon diem da biet cao...

Lisp tính cao độ của mình khi tính xong thì các cao độ tìm được luôn nằm lệch sang bên trái điểm cần tìm.
Mình nhờ các bạn sửa lại cho mình : sao cho các số cao độ tìm được có điểm cần tìm làm trung tâm.


(defun c:h1 ( / pt p1 p01 p02 ent ecopy elev elev1 offset etype txth)
(setvar "osmode" 1)
(command "ucs" "w")
(setq pt (getpoint "\nChon diem da biet cao do: ")
ent (entget(car(entsel "\nChon gia tri cao do cho diem vua xong: ")))
etype (cdr(assoc 0 ent))
txth (cdr(assoc 40 ent))
)
(if (/= etype "TEXT") (progn
(princ "\nGia tri ban chon khong phai la so")
(exit))
(setq elev (atof(cdr(assoc 1 ent))))
)
(command "layer" "m" "UNSUITABLE" "")
(while (setq p1(getpoint "\nChon diem can tim cao do"))
(setq elev1 (+ elev (- (cadr p1) (cadr pt)))
offset (abs(- (car p1) (car pt)))
p01 (polar p1 (* 3.0 (/ pi 2)) txth)
p01 (polar p01 pi (* 0.9 txth))
p02 (polar p01 0 (* 1.6 txth))
ecopy (list (assoc 0 ent)
(cons 100 "AcDbEntity")
(cons 8 "UNSUITABLE")
(cons 100 "AcDbText")
(assoc 10 ent)
(assoc 40 ent)
(cons 1 (strcat "" (rtos elev1 2 2)))
(assoc 50 ent)
(assoc 41 ent)
(assoc 51 ent)
(assoc 7 ent)
(cons 71 0)
(cons 72 2)
(list 11 (car p01) (cadr p01) 0.0)
(list 210 0.0 0.0 1.0)
(cons 100 "AcDbText")
(cons 73 2)
)
)
(entmake ecopy)
(princ "\nNhan ESC hoac SPACE bar de huy lenh")
)
(end_task)
)

mình dùng acad2007 sử dụng lisp sau:

(defun c:test()
(setq t1 (getstring T "\nNhap noi dung text 1: ")
t2 (getstring T "\nNhap noi dung text 2: ")
t3 (strcat t1 t2)
)
)


Vấn đề đặt ra là cách nhập text (t1 và t2) trên dong lệnh command và tại vị trí con trỏ trên màn hình:
- Nhập trên dòng lệnh thì các text t1 và t2 vẫn đầy đủ
vd: t1 "Forum...

mình dùng acad2007 sử dụng lisp sau:

(defun c:test()
(setq t1 (getstring T "\nNhap noi dung text 1: ")
t2 (getstring T "\nNhap noi dung text 2: ")
t3 (strcat t1 t2)
)
)


Vấn đề đặt ra là cách nhập text (t1 và t2) trên dong lệnh command và tại vị trí con trỏ trên màn hình:
- Nhập trên dòng lệnh thì các text t1 và t2 vẫn đầy đủ
vd: t1 "Forum " và t2 " CadViet " => "Forum CadViet "

- Nhập tại vị trí con trỏ thì các text bị mất khoảng trắng đầu và cuối
vd: t1 "Forum " và t2 " CadViet" => "ForumCadViet"

Vậy có cách nào để khắc phục cho cách nhập tại vị trí con trỏ không? hoặc có biến hệ thống nào để cài đặt bắt buộc chỉ được nhập tại dòng lệnh command

Thanks

Lisp của mình cần cũng tương tự như Link trên .Nhưng thay vì kết quả là tính "Sum" hay "Mul" thì của mình là "khoảng cách" và đối tượng được chọn của mình là Line hoặc Pline chứ không phải là TEXT
( Ý mình là muốn đo khoảng cách giữa các đường màu đỏ, và kết quả mình sẽ chọn Text để ghi thay thế)
Các bác xem và chỉnh sửa hộ nhé !

>>

Lisp của mình cần cũng tương tự như Link trên .Nhưng thay vì kết quả là tính "Sum" hay "Mul" thì của mình là "khoảng cách" và đối tượng được chọn của mình là Line hoặc Pline chứ không phải là TEXT
( Ý mình là muốn đo khoảng cách giữa các đường màu đỏ, và kết quả mình sẽ chọn Text để ghi thay thế)
Các bác xem và chỉnh sửa hộ nhé !

;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj(ss1 MyType / ss2 i e)
(setq ss2 (ssadd) i 0)
(repeat (sslength ss1)
(setq e (ssname ss1 i) i (1+ i))
(if (CheckObj e MyType) (ssadd e ss2) )
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData( / OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0) (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
)
;;;-----------------------------------------
(defun WriteRes(kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT") (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
(entmod (subst (cons 1 (rtos kq)) (assoc 1 (setq data (entget e))) data))
(princ)
)
;;;-----------------------------------------
(defun C:MUL( / i m e ss)
(SelData) (setq i 0 m 1.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) m (* m (atof (cdr (assoc 1 (entget e)))))))
(WriteRes m)
)
;;;-----------------------------------------
(defun C:SUM( / i s e ss)
(SelData) (setq i 0 s 0.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) s (+ s (atof (cdr (assoc 1 (entget e)))))))
(WriteRes s)
)
;;;-----------------------------------------

Em xin lỗi vì em giải thích ý tưởng của em nhưng mãi ko ai hiểu. Không biết các bác có xem file đính kèm cuối cùng của em chưa, nếu xem rồi, chỉ cần các bác giúp em làm được như ví dụ trong file đính kèm đó là em cảm ơn rồi. link file đính kèm đây ạ. http://www.cadviet.com/link/?f=upfiles/3/62874_drawing3_1.dwg&w=64013 . Em nghix là xem ví dụ là có thể hiểu đc rồi chứ a. Cảm ơn mọi...

Em xin lỗi vì em giải thích ý tưởng của em nhưng mãi ko ai hiểu. Không biết các bác có xem file đính kèm cuối cùng của em chưa, nếu xem rồi, chỉ cần các bác giúp em làm được như ví dụ trong file đính kèm đó là em cảm ơn rồi. link file đính kèm đây ạ. http://www.cadviet.com/link/?f=upfiles/3/62874_drawing3_1.dwg&w=64013 . Em nghix là xem ví dụ là có thể hiểu đc rồi chứ a. Cảm ơn mọi người nhiều.
Còn đây là lips CV copy thông minh của em :

;COP THONG MINH
(defun xulytext (text / kytu ma sokt luusokt lui )
(setq kytu (substr text (strlen text))
ma (ascii kytu)
sokt (read kytu)
lui 1
)
(if (numberp sokt)
(progn
(setq luusokt (1+ sokt))
(if (and (numberp sokt)
(> (strlen text) 1)
)
(progn
(setq kytu (substr text (1- (strlen text)))
sokt (read kytu)
)
(if (numberp sokt)
(setq luusokt (1+ sokt)
lui 2
)
)
);progn
)
(if (= luusokt 100) (setq luusokt 0))
(setq kytu (rtos luusokt 2 0)

text (strcat (substr text 1 (- (strlen text) lui)) kytu)
)
);progn
(if (or (= kytu "z")
(= kytu "Z")
)
(setq text (strcat text "0")
textxl "0"
)
(setq ma (1+ ma)
text (strcat (substr text 1 (1- (strlen text))) (chr ma))
)
);if
);if
)
;*********************************************************************
(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)
;Neu doi tuong la text thi tiep tuc
(setq doituong (entget tendoituong)
kieu (cdr (assoc 0 doituong))
canle (cdr (assoc 72 doituong))
)
(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(progn
(setq textxl (xulytext textxl)
text (cons 1 textxl)
vitri10 (cdr (assoc 10 doituong))
vitri10 (list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))
vitri10 (cons 10 vitri10)
vitri11 (cdr (assoc 11 doituong))
vitri11 (list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))
vitri11 (cons 11 vitri11)
dem 0
dsach nil
)
(foreach tam doituong
(cond
((= (car tam) 1) (setq dsach (append dsach (list text))))
((= (car tam) 10) (setq dsach (append dsach (list vitri10))))
((= (car tam) 11) (setq dsach (append dsach (list vitri11))))
((setq dsach (append dsach (list tam))))
)
)
(entmake dsach)
);progn
);if
);
;sao doi tuong cu sang vi tri moi
(defun copy_dt (tendoituong )
(command "copy" tendoituong "" goc toi )
);defun
(defun c:CV ( / cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
(princ "\nCopy Inteligent...\n")
(setq luuecho (getvar "cmdecho")
luu *error*
*error* ketthuc
cumdt (ssget)
dodai (sslength cumdt)
goc (getpoint "\nXin Ngai cho con toi mot diem khac:")
thoat nil
dem 0
textxl nil
);
(setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
(while (and (= thoat nil)
(< dem dodai)
)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)

(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(setq thoat T
textxl (cdr (assoc 1 doituong))
)
)
);
(while T
(setq toi (getpoint "\nCho con toi diem khac nua di: " goc)
vitrilech (list (- (car toi) (car goc)) (- (nth 1 toi) (nth 1 goc)))
dem 0
)
(while (< dem dodai)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)
(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(doitext ten)
(copy_dt ten)
);if
)
);while
(ketthuc)
)

(Defun c:taodim ()
(setvar "cmdecho"0)


(command "DIMBLK""archtick")
(command "DIMASZ"2)
(command "DIMCEN"0)
(command "DIMTIH" off)
(command "DIMTDEC" 2)
(command "DIMZIN" 8)
(command "DIMAZIN" 2)
(command "DIMTOH" "OFF")
(command "DIMTIH" "OFF")
(command "DIMEC"...

(Defun c:taodim ()
(setvar "cmdecho"0)


(command "DIMBLK""archtick")
(command "DIMASZ"2)
(command "DIMCEN"0)
(command "DIMTIH" off)
(command "DIMTDEC" 2)
(command "DIMZIN" 8)
(command "DIMAZIN" 2)
(command "DIMTOH" "OFF")
(command "DIMTIH" "OFF")
(command "DIMEC" 2)

(command "DIMCLRT"256)
(command "DIMTXT"2)
(command "DIMTAD"1)
(command "DIMGAP"1)
(command "DIMCLRD" 256)
(command "DIMLTYPE""BYLAYER")
(command "DIMLWD"-1)
(command "DIMDLE"1)
(command "DIMDLI"6)


(Command "DIMCLRE"256)
(command "DIMLTEX1""BYLAYER")
(command "DIMLTEX2""BYLAYER")
(command "DIMEXE"1)
(command "DIMEXO"0)
(command "DIMLWE"-1)




(command "DIMATFIT"3)
(command "DIMTMOVE"0)
(SETVAR "DIMSCALE" 0)
(command "DIMTOFL""ON")



(command "DIMDEC"2)
(command "DIMDSEP"".")
(command "DIMLUNIT"2)


(command "DIMLWD"-1)
(command "DIMLWE"-1)

(IF (NOT (TBLSEARCH "STYLE""DIM"))
(command "-style" "DIM" "romans.shx" "" "" "" "" "" "" )
)

(COMMAND "DIMTXSTY" "DIM")


(Command ".dimstyle""s""xxxxx100")
(prompt "da tao xong dimstyle xxxxx100 dat lam hien hanh")
(setvar "cmdecho"1)

);end c:

trước mình làm list này sau thì thấy hình như cũng chưa hợp lý lắm; bạn dùng tạm xem
1. nếu mún dùng list làm tạo DIMSTYLE của MODEL sửa biến DIMSCALE về một số khác 0
2. Nếu mún sửa tên lệnh thay dòng (defun c:taodim() bằng dòng (defun c:
3. hình như mình thấy để các cặp khoảng nhô và chiều cao chữ, khoảng cách chữ đến DIM là 1, 2.5, và 1 là hơi to bạn mình vẫn thường chỉnh lại là 1(/0.8), 1.8, và 0.5 tùy bạn thôi trước mắt bạn cử nhìn vào kết quả list làm được và sửa theo ý mình là được

Chào bạn sucuph,
Lisp đầy đủ đây ạ:


Bạn lưu ý là khi lisp yêu cầu bạn chọn mái doc thì bạn phải chọn vào đúng mái dốc cần xác định độ dốc chứ không được nhấn enter ngay nha.
Khi góc dốc >pi/2 bạn sẽ thấy text bị lộn ngược và tùy theo ý bạn có thể để nguyên hay rotate nó nhé.
Bạn lưu ý thêm là mình có thay đổi cái cách xác định góc xoay...

Chào bạn sucuph,
Lisp đầy đủ đây ạ:


Bạn lưu ý là khi lisp yêu cầu bạn chọn mái doc thì bạn phải chọn vào đúng mái dốc cần xác định độ dốc chứ không được nhấn enter ngay nha.
Khi góc dốc >pi/2 bạn sẽ thấy text bị lộn ngược và tùy theo ý bạn có thể để nguyên hay rotate nó nhé.
Bạn lưu ý thêm là mình có thay đổi cái cách xác định góc xoay của text do hàm angle trả ra giá trị theo radian mà lệnh text yêu cầu nhập giá trị theo độ.
Trong trường hợp mái dốc của bạn không phải là đường line thì góc ang sẽ là góc của điểm đầu và điểm cuối của đường polyline hay spline đó bạn nhé.
Mình đã chạy thử lisp ngon.

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