| Info | File |
Tác giả: NTD
Bài viết gốc: 208175
Tên lệnh: ha |
Lisp chọn đối tượng thì các style của nó hiện hành
;Doan Van Ha - CADViet.com - Ngay 03/4/2012
;Muc dich: Set Curent theo doi tuong chon: Layer, Linetype, Colour, Textstyle (*text) or...
>>
;Doan Van Ha - CADViet.com - Ngay 03/4/2012
;Muc dich: Set Curent theo doi tuong chon: Layer, Linetype, Colour, Textstyle (*text) or Dimstyle (dimension).
(defun C:HA()
(setq lst (entget (car (entsel "\nChon 1 doi tuong Text/Mtext/Dimension de Set Current: "))))
(setvar "CLAYER" (cdr (assoc 8 lst))) ;Layer
(setvar "CELTYPE" (cond ((cdr (assoc 6 lst))) ("BYLAYER"))) ;Linetype
(setvar "CECOLOR" (_GetColour lst)) ;Colour
(cond ;TextStyle or DimStyle
((wcmatch (cdr (assoc 0 lst)) "*TEXT") (setvar "TEXTSTYLE" (cdr (assoc 7 lst))))
((wcmatch (cdr (assoc 0 lst)) "DIMENSION") (command "DIMSTYLE" "r" (cdr (assoc 3 lst)))))
(princ))
;-----
(defun _GetColour ( e / c )
(if (setq c (cdr (assoc 62 e)))
(cond
((cdr (assoc c '((0 . "ByBlock") (1 . "Red") (2 . "Yellow") (3 . "Green") (4 . "Cyan") (5 . "Blue") (6 . "Magenta") (7 . "White")))))
((itoa c)))
"ByLayer"))
Thanks bác , Lisp hay quá , bác thêm cho trường hợp Linetype Scale đc ko ? . Tức là Global scale factor trong Linetype Manager vẫn ko thay đổi nhưng những đối tượng vẽ ra sau khi dùng Lisp của bác sẽ có Linetype Scale theo đối tượng đc chọn . Cảm ơn bác lần nữa
<<
|
Tác giả: buratino1703
Bài viết gốc: 9681
Tên lệnh: co |
Đánh số thứ tự tăng dần
Lệnh copy thông minh: Command: co
mình dùng thấy thú vị hơn lệnh Tcount, tuy nhiên mỗi cái có điểm hay riêng.
;;;Edit by...
>>
Lệnh copy thông minh: Command: co
mình dùng thấy thú vị hơn lệnh Tcount, tuy nhiên mỗi cái có điểm hay riêng.
;;;Edit by Interwar1283
;*********************************************************************
(defun ketthuc ()
(setvar "cmdecho" luuecho)
(setq *error* luu
luu nil
luuecho nil
);setq
(princ)
)
;*********************************************************************
(defun modau ()
(setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
)
)
;*********************************************************************
(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:co ( / 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 "\nSelect base point:")
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 "\nSelect next point: " 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
(princ "Type \"DG\" to start")
;Note: bien toan cuc: textxl vitrilech
Lệnh của bác đến 100 thì die, vì khi đánh số đến 101 thì nó hiện 1, 102 hiện 2(quay vòng)! Khắc phục bằng cách nào vậy bác?
<<
|
Tác giả: trieubb
Bài viết gốc: 267103
Tên lệnh: ha |
(Yêu cầu) Lisp cộng một số không đổi vào lý trình khi thiết kế đườn
Thử cái này xem đã đúng ý chưa.
;Doan Van Ha - CADViet.com - Ngay 02/4/2012
;Muc dich:...
>>
Thử cái này xem đã đúng ý chưa.
;Doan Van Ha - CADViet.com - Ngay 02/4/2012
;Muc dich: tang/giam nhieu ly trinh voi cung 1 gia tri (VD ky hieu ly trinh: "Km:0+00.00", can tang 100.00)
;So chu so le phu thuoc ket qua.
(defun C:HA( / entlst tang)
(princ "\nChon cac Text ly trinh can tang/giam...")
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT") (1 . "Km:*")))))))
(setq tang (getreal "\nNhap gia tri (met) tang/giam: "))
(foreach ent entlst
(entmod (subst (cons 1 (HA (cdr (assoc 1 (entget ent))) tang)) (assoc 1 (entget ent)) (entget ent))))
(princ))
;----- VD: txtcu = "Km:0+20.32" ; tang = 100.00
(defun HA(txtcu tang / trai phai txtmoi)
(setq somoi (+ (* (atoi (TRAI_STR (substr txtcu 4) "+")) 1000) (atof (PHAI_STR (substr txtcu 4) "+")) tang))
(setq trai (fix (/ somoi 1000.0)))
(setq phai (- somoi (* trai 1000)))
(strcat "Km:" (itoa trai) "+" (if (= phai (atoi (rtos phai 2 0))) (rtos phai 2 0) (rtos phai 2 2))))
(defun TRAI_STR(str str1) (if (acet-str-find str1 str) (substr str 1 (- (acet-str-find str1 str) 1))))
(defun PHAI_STR(str str1) (if (TRAI_STR str str1) (substr str (+ 1 (strlen str1) (strlen (TRAI_STR str str1))))))
Lisp hay nhưng bác xem lại có 1 lỗi như sau: VD Km:1+5.45 cộng vào 5m nữa kết quả thành Km:0+10.45
Thứ hai là bác có thể sửa cái chữ số m ấy lúc nào cũng là 3 số VD Km:1+5.45 thành Km:1+005.45
<<
|
Tác giả: gia_bach
Bài viết gốc: 25764
Tên lệnh: xsc |
Scale đối tượng một chiều
Đây là đọan code scale đối tượng một chiều Lệnh là XSC hoặc XSCALE
;Scale the mot chieu
(DEFUN EXCUTE()
..................
(setq P0...
>>
Đây là đọan code scale đối tượng một chiều Lệnh là XSC hoặc XSCALE
;Scale the mot chieu
(DEFUN EXCUTE()
..................
(setq P0 (getpoint "\nChon diem goc: "))
(initget 1 "X Y X S")
(setq C (getkword "\nScale theo ? :"))
(setq hs (getreal "Cho biet he so scale: "))
(DELBLOCK "vkc_temp")
(CREATEBLOCK ss P0)
(Command "-Insert" "vkc_temp" C hs P0 "")
(setq dt (entlast))
(Command "Explode" dt)
(setvar "CMDECHO" oldvalue)
(princ)
)
........
(DEFUN DELBLOCK (bname)
(if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")
)
)
..............
(DEFUN C:XSC()
(CREALIBLK)
(EXCUTE)
)
Trường hợp trên bản vẽ có Block name vkc_temp thì hàm DELBLOCK sẽ không có tác dụng--> báo lỗi,
do đó Vndesperados nên đặt tên Block theo cách khác.
<<
|
Tác giả: phamthanhbinh
Bài viết gốc: 183525
Tên lệnh: lbhg |
Lisp thống kê cao độ ga và cống
Bác bach1212 có cái lisp lập bảng tọa độ ngon rùi, nên mình mượn...
>>
Bác bach1212 có cái lisp lập bảng tọa độ ngon rùi, nên mình mượn lại biến tấu chút thì cái vụ nhập hố ga của bạn cũng tạm ổn rùi đấy
Bạn chạy lại bằng code lisp này xem nhé.
Nếu bảng chưa đẹp, đúng như bác phamthanhbinh nói, nên thêm mắm muối vào nữa cho vừa khẩu vị từng người.
Lưu ý rằng: free code lisp from CADViet - em chỉ xào nấu chút thui
: Ha Van Khanh 3/2003
;
; * Chuong trinh duoc lap bang ngon ngu AUTOLISP.
; Free lisp code from CADViet - Edit by mathan
; ------------------------------------------------------------------------------
(vmon)
(defun C:LBHG (/ 1x 1y a1 2x 2y a2 3x 3y a3 b p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16x p16y p16 p17x p17y p17)
(setvar "cmdecho" 0)
(initget 7)
(setq osm (getvar "osmode" ))
(setvar "osmode" 0)
(command "-Style" "hoatbif" "hoatbif " "2.5" "" "" "" "" "")
(command "-Layer" "n" "Text" "c" "4" "Text" "")
(setq p1 (getpoint "\nChon diem dat bang thong ke :"))
(setq S (getint "\nSo ho ga can thong ke:"))
(setq p2 (polar p1 (/ (* Pi 3) 2) (+ 16 (* 8 S))))
(setq p3 (polar p2 0 91))
(setq p4 (polar p1 0 91))
(setq p5 (polar p1 0 21))
(setq p6 (polar p2 0 21))
(setq p7 (polar p5 0 35))
(setq p8 (polar p6 0 35))
(setq p9 (polar p5 (/ (* Pi 3) 2) 8))
(setq p10 (polar p4 (/ (* Pi 3) 2) 8))
(setq p12 (polar p9 0 35))
(setq p11 (polar p9 0 -10.5))
(setq p13 (polar p1 (/ (* Pi 3) 2) 16))
(setq p14 (polar p4 (/ (* Pi 3) 2) 16))
(setq p15 (polar p7 (/ (* pi 3 ) 2) 4))
(setq p16x (/ (+ (car p5) (car p7)) 2))
(setq p16y (/ (+ (cadr p9) (cadr p13)) 2))
(setq p17x (/ (+ (car p4) (car p7)) 2))
(setq p17y (/ (+ (cadr p9) (cadr p13)) 2))
(setq p16 (list p16x p16y))
(setq p17 (list p17x p17y))
(command "Plinewid" "0.5")
(command "Pline" p1 p2 p3 p4 p1 "")
(command "Line" p5 p6 "")
(command "Line" p12 p8 "")
(command "Line" p9 p10 "")
(command "Line" p13 p14 "")
(command "Array" "l" "" "Rec" S "1" "-8")
(command "text" "j" "mc" p11 "0" "Ten Ga" )
(command "text" "j" "mc" p15 "0" "Cao do" )
(command "text" "j" "mc" p16 "0" "D" )
(command "text" "j" "mc" p17 "0" "Y" )
(setvar "osmode" 1)
;-------------------------------------------------
; Phan chinh
(prompt "\nBan can pick tung text theo thu tu Ten ho ga; cao do dinh va cao do day ga: ")
(setq b 0)
(while (< b s )
(setq b (+ b 1))
(setq ss (car (entsel "\nDS> Ten ho ga: ")))
(setq tenga (cdr (assoc 1 (entget ss))))
(setq ss (car (entsel "\nDS> Cao do dinh: ")))
(setq cddinh (cdr (assoc 1 (entget ss))))
(setq ss (car (entsel "\nDS> Cao do day: ")))
(setq cdday (cdr (assoc 1 (entget ss))))
(setq 1x (/ (+ (car p1) (car p5)) 2))
(setq 1y (- (- (cadr p11) 4) (* 8 B)))
(setq a1 (list 1x 1y))
(setq 2x (/ (+ (car p5) (car p7)) 2))
(setq 2y (- (cadr p16) (* 8 B)))
(setq a2 (list 2x 2y))
(setq 3x (/ (+(car p7) (car p4)) 2))
(setq 3y (- (cadr p17) (* 8 B)))
(setq a3 (list 3x 3y))
(command "text" "j" "mc" a1 "0" tenga "" )
(command "text" "j" "mc" a3 "0" cddinh "" )
(command "text" "j" "mc" a2 "0" cdday "" )
)
)
Bác bach1212 dùng vui vẻ nhé.
Tiện thể cho e mượn code em đồ thêm mấy cái lisp khác nha.
Thank all
Hề hề hề,
Bác cho hỏi là cái hàm (vmon) dùng làm cái chi vậy ạ????
<<
|
|
Filename: 183525_lbhg.lsp
|
|
Tác giả: hugo007
Bài viết gốc: 164066
Tên lệnh: cdt |
Lisp cắt đối tượng
Bạn dùng thử cái này xem nhé.
(defun C:CDT( / sl dt giao )
(setq oldos (getvar "osmode") oldcm (getvar...
>>
Bạn dùng thử cái này xem nhé.
(defun C:CDT( / sl dt giao )
(setq oldos (getvar "osmode") oldcm (getvar "cmdecho"))
(setvar "osmode" 0) (setvar "cmdecho" 0)
(princ "Chon cac Line can cat: ")
(setq sl (acet-ss-to-list (ssget '((0 . "LINE")))))
(setq dt (entsel "Chon Line cat: "))
(foreach n sl
(setq giao (inters (cdr (assoc 10 (entget n))) (cdr (assoc 11 (entget n))) (cdr (assoc 10 (entget (car dt)))) (cdr (assoc 11 (entget (car dt))))))
(command "break" n giao giao))
(setvar "osmode" oldos)
(setvar "cmdecho" oldcm)
(princ))
(princ "Lenh cat doi tuong: CDT")
Đường polyline không cắt được sao bạn?Nhờ bạn sửa cho chọn được nhiều line cắt,sau khi cắt xong các đoạn thẳng vừa mới bị cắt ra,đoạn ngắn nhất thì sẽ bị xoá đi.Thanks.
<<
|
Tác giả: Hai_YenLang
Bài viết gốc: 196968
Tên lệnh: tl |
viết lisp tính chiều dài đường ống nước
Còn một cái mơ hồ mơ hồ chưa rõ ràng nữa là đường ống tổng chính, tổng phụ, và các nhánh chia về các hộ gia đình phải có tiết diện to nhỏ khác nhau. Tính gộp cả tổng chiều dài hổ lốn các đoạn ống có tiết diện khác nhau như thế, chả hiểu có ý nghĩa gì về mặt thống kê?
- Có thể chia từng nhánh thành các layer khác nhau để tính tổng cho từng loại
- Khóa layer các...
>>
Còn một cái mơ hồ mơ hồ chưa rõ ràng nữa là đường ống tổng chính, tổng phụ, và các nhánh chia về các hộ gia đình phải có tiết diện to nhỏ khác nhau. Tính gộp cả tổng chiều dài hổ lốn các đoạn ống có tiết diện khác nhau như thế, chả hiểu có ý nghĩa gì về mặt thống kê?
- Có thể chia từng nhánh thành các layer khác nhau để tính tổng cho từng loại
- Khóa layer các đường ống, chỉ để lại layer text , sử dụng lệnh Li có thể biết được tổng số hộ.
- Bạn thử tham khảo các lisp sau:
Lisp tính tổng chiều dài của mọi đối tượng có thuộc tính chiều dài (line, pline, spline, arc, circle, ellipse). Lệnh TL:
;;;--------------------------------------------------------------------(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)));;;--------------------------------------------------------------------(defun C:TL( / ss L e)(setq ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))) L 0.0)(vl-load-com)(while (setq e (ssname ss 0)) (setq L (+ L (length1 e))) (ssdel e ss))(alert (strcat "Total length = " (rtos L))));;;--------------------------------------------------------------------
Mặc dù bài viết này đã lâu rồi nhưng mình vẫn trả lời (biết đâu có người cần dùng).
Lisp Lencal sau đây có thể tính tổng chiều dài các loại đường trong một bản vẽ theo cùng layer, cùng loại nét hay cùng màu sắc.
http://www.cadviet.c.../lencal_v17.lsp
(lệnh: lencal)
Tác giả: Lee Mac. Nguồn: CadTutor
<< |
Tác giả: thong_kt
Bài viết gốc: 62755
Tên lệnh: sct |
Cách scale nhiều đối tượng một lúc?
Tue_NV đồng ý với ý kiến của anh Duy782006. Đây là lisp scale tất cả đường tròn cùng một lúc nhưng có tâm scale là tâm của từng đường tròn
>>
Tue_NV đồng ý với ý kiến của anh Duy782006. Đây là lisp scale tất cả đường tròn cùng một lúc nhưng có tâm scale là tâm của từng đườ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)
)
:s_big:
Cảm ơn anh. Với text thì em đã thấy lisp scale tại điểm chèn của text rùi. Với block thì việc scale là đơn giản. Em muôn hỏi với một hình bất kỳ. Nếu là hình scale nhiều hình chữ nhật, wipeout một lúc. Tâm scale tại điểm pick chuột trên cạnh của hình chữ nhật. Cũng giống như với hình tròn nhưng giơ tâm scale là điểm pick chuột trên cạnh hình chữ nhật hay một điểm lằm bên cạnh hình chữ nhật. Mong anh giúp đỡ.
<<
|
Tác giả: Tue_NV
Bài viết gốc: 106409
Tên lệnh: tichso |
Viết lisp theo yêu cầu [phần 2]
hề hề, làm gì mà bác nóng tính thế. em up cái hình lên đây, hy vọng biểu đạt được ý nguyện của mình thực ra mình cũng đã viết 1 lisp để làm công việc nhân...
>>
hề hề, làm gì mà bác nóng tính thế. em up cái hình lên đây, hy vọng biểu đạt được ý nguyện của mình thực ra mình cũng đã viết 1 lisp để làm công việc nhân nhiều số với 1 số, nhưng nó vẫn còn 1 số hạn chế :
chưa áp dụng được cho số thực ( mình cũng đã chỉnh lại kiểu dữ liệu nhập vào là với số thực, nhưng chẳng hiểu sao lúc được lúc không, lúc lại cho ra KQ ko đúng)
nếu tích số nhận xong là số nguyên, nó không có ".0"
(defun c:tichso()
(setq i (getint "\n Enter number to calculate :"))
(prompt "Select objects:")
(setq ss (ssget))
(setq cnt 0)
(progn
(repeat (sslength ss)
(setq ent (entget (ssname ss cnt)))
(setq nd1 (cdr (assoc 1 ent)))
(setq nd2 (distof nd1))
(setq nd3 (/ nd2 i))
(setq nd4 (rtos nd3 2 1))
(setq nd nd4)
(setq ent (subst (cons 1 (strcat nd)) (assoc 1 ent) ent))
(entmod ent)
(setq cnt (1+ cnt))
)
)
)
1. Bạn đã thử chức năng tìm kiếm của diễn đàn chưa? Hãy Tìm kiếm với từ khoá Nhan 2 cot so
->> nên sử dụng Table của CAD hơn là phải sử dụng Text như thế. Mình chỉ sử dụng Lisp này để kiểm tra lại mấy anh sử dụng Text để thống kê, chứ tuyệt đối không dùng Text để nhân 2 cột số vì nó không ưu điểm bằng Table của ACAD
2. Theo ý của bạn master_worse. hoặc sử dụng Lisp này của Tue_NV :
Chương trình tính toán Cộng trừ Nhân Chia giá trị của Block Attribute; Text với 1 số hoặc 1 biểu thức
Chương trình cũng có tính năng làm tròn số tới một số nào đó do User định trước
<<
|
|
Filename: 106409_tichso.lsp
|
|
Tác giả: kloud7
Bài viết gốc: 195239
Tên lệnh: ha |
Lisp chọn đối tượng thì các style của nó hiện hành
;Doan Van Ha - CADViet.com - Ngay 03/4/2012
;Muc dich: Set Curent theo doi tuong chon: Layer, Linetype, Colour, Textstyle (*text) or...
>>
;Doan Van Ha - CADViet.com - Ngay 03/4/2012
;Muc dich: Set Curent theo doi tuong chon: Layer, Linetype, Colour, Textstyle (*text) or Dimstyle (dimension).
(defun C:HA()
(setq lst (entget (car (entsel "\nChon 1 doi tuong Text/Mtext/Dimension de Set Current: "))))
(setvar "CLAYER" (cdr (assoc 8 lst))) ;Layer
(setvar "CELTYPE" (cond ((cdr (assoc 6 lst))) ("BYLAYER"))) ;Linetype
(setvar "CECOLOR" (_GetColour lst)) ;Colour
(cond ;TextStyle or DimStyle
((wcmatch (cdr (assoc 0 lst)) "*TEXT") (setvar "TEXTSTYLE" (cdr (assoc 7 lst))))
((wcmatch (cdr (assoc 0 lst)) "DIMENSION") (command "DIMSTYLE" "r" (cdr (assoc 3 lst)))))
(princ))
;-----
(defun _GetColour ( e / c )
(if (setq c (cdr (assoc 62 e)))
(cond
((cdr (assoc c '((0 . "ByBlock") (1 . "Red") (2 . "Yellow") (3 . "Green") (4 . "Cyan") (5 . "Blue") (6 . "Magenta") (7 . "White")))))
((itoa c)))
"ByLayer"))
Thks bác, cái này mà bản vẽ nhiều dim nhiều linetype thì tiện phải biết cheer !!
<<
|
Tác giả: kimvantoan
Bài viết gốc: 229850
Tên lệnh: ca |
Lisp kết hợp lệnh Array và Copy
Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.
Lệnh này Copy_Array các đối tượng, kể...
>>
Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.
Lệnh này Copy_Array các đối tượng, kể cả Text (Mtext). Riêng Text chứa số thì có thể tăng/giảm theo gia số, nó chấp nhận cả số có tiền và/hoặc hậu tố.
Nếu có nhiều Text số được chọn thì chỉ 1 Text số chọn sau cùng được tăng/giảm. Số chữ số thập phân (nếu có) sẽ lấy theo Text chọn.
; Doan Van Ha CADViet.com
; Copy-Array cac doi tuong ke ca Text (Mtext), rieng Text co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
; P/S (01-03-2012): bo sung them so chu so 0 dau num de phu hop voi text mau. VD: "CN: 01" tang thanh "CN: 02"...
(defun C:CA (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
(vl-load-com)
(command "undo" "be")
(setq osm (getvar "osmode") cmd (getvar "cmdecho"))
(princ "\nChon cac doi tuong can Copy-Array...")
(setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
dt1 dt p1 (getpoint "\nDiem goc: ") p2 (getpoint p1 "\nDiem den: ") sl (getint "\nSo lan: ") x 1)
(setvar "osmode" 0) (setvar "cmdecho" 0)
(foreach n dsdt
(if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
(if (KT_NUM (cdr (assoc 1 (entget n))))
(setq dt2 n))))
(if dt2 (setq dt1 (ssdel dt2 dt)))
(if dt2
(progn
(initget "Y N")
(setq kwrd (getkword "\nBan muon Text tang dan ? ") giaso (getreal "\nGia so: "))
(setq x 1)
(repeat (1- sl)
(command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
(if (eq kwrd "Y")
(progn
(CHIA3 (cdr (assoc 1 (entget dt2))))
(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
(entupd (entlast))))
(setq x (1+ x)))))
(if dt1
(progn
(setq x 1)
(repeat (1- sl)
(command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
(setq x (1+ x)))))
(command "undo" "e")
(setvar "osmode" osm) (setvar "cmdecho" cmd)
(princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
(setq lstt (vl-string->list str) lstn (reverse lstt))
(while lstt
(cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
(T (setq lstt nil))))
(while lstn
(cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
(T (setq lstn nil))))
(setq ds (list (vl-list->string (reverse trai))
(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
(foreach n (vl-string->list str)
(if (and (>= n 48) (<= n 57)) (setq kt T)))
kt)
;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
(setq m 0)
(while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
(setq m (1+ m) str (substr str 2)))
m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
(while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
(setq strs (strcat "0" strs)))
strs)
P/S: sửa 07/02/2012 để không còn dùng các hàm Acet.P/S: sửa 01/03/2012 để thêm số chữ số 0 vào đầu Num của Text để phù hợp với Text gốc.
Chào bác Doan Van Ha! Không biết bác có còn theo dõi topic này nữa không. Nếu bác còn theo dõi thì giải quyết giúp tôi vấn đề này với. Tôi đã dowload lisp của bác về dùng. Lisp dùng rất hay và đáp ứng được nhu cầu sử dụng của tôi. Nhưng tôi muốn thay đổi việc "nhập hai điểm đầu tiên là khoảng cách các text và nhập số lần là số text cần copy" bằng việc "nhập hai điểm đầu tiên là khoảng mà text sẽ copy(ví dụ trong khoảng 100m) và chọn hai điểm tiếp theo để lấy khoảng cách giữa hai text(ví dụ là 1m). Tôi thấy làm như thế thì sẽ tiện hơn khi sử dụng(theo tôi là như vậy). Tôi có sưu tầm được một lisp copy và array như thế, nhưng nó không tăng được số. Đây là lisp tôi đang sử dụng http://www.cadviet.com/upfiles/3/67165_copyarray.lsp
Rất cám ơn bác về lisp của bác!
<<
|
Tác giả: quanvuong
Bài viết gốc: 50119
Tên lệnh: od oc |
Đánh số thứ tự tăng dần
Bạn dùng thử chương trình sau. Có 2 lệnh: 1) Lệnh OD: Ordinate number with any format. Đánh số thứ tự với bất kỳ định dạng nào: số, chữ, chữ và số. Ví dụ:
Command:...
>>
Bạn dùng thử chương trình sau. Có 2 lệnh: 1) Lệnh OD: Ordinate number with any format. Đánh số thứ tự với bất kỳ định dạng nào: số, chữ, chữ và số. Ví dụ:
Command: od
Begin at <1>: HTT-01-03. Nếu không nhập số, bấm Enter sẽ mặc định từ 1
Increment <1>: 3. Nếu không nhập số, bấm Enter sẽ lấy mặc định là 1
Base point <exit>: chỉ điểm -> HTT-01-03
Base point <exit>: chỉ điểm -> HTT-01-06
Base point <exit>: chỉ điểm -> HTT-01-09
.........
Đến khi... chán thì:
Base point <exit>: Enter -> Thoát
2) Lệnh OC: Ordinate number, Copy from template. Đánh số thứ tự bằng cách copy mẫu có sẵn. Hoạt động giống như trên, nhưng thay vì "Begin at" thì chọn một mẫu có sẵn và 1 điểm tham chiếu làm chuẩn (tương tự như trình của bạn Lê Huy Hà nhưng có thêm tính năng tùy chọn Increment theo ý bạn).
Các bạn dùng nếu thấy có gì bất ổn thì phản hồi để mình sửa.
;;;------------------------------------------------------------------------------------
(defun getTw() ;;;Get textstyle
(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun getTh( / Th) ;;;Get textheight or textsize
(if (= (setq Th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0) (getvar "textsize") Th)
)
;;;------------------------------------------------------------------------------------
(defun emkT (S p) ;;;Entmake text S at p
(entmake (list (cons 0 "TEXT") (cons 10 p) (cons 40 (getTh))
(cons 41 (getTw)) (cons 1 S) (cons 7 (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun incN (n dn / n2 i n1) ;;;Increase number n
(setq
n2 (itoa (+ dn (atoi n)))
i (- (strlen n) (strlen n2))
)
(if (> i 0) (setq n1 (substr n 1 i)) (setq n1 ""))
(strcat n1 n2)
)
;;;------------------------------------------------------------------------------------
(defun incC (c / i c1 c2) ;;;Increase character c
(setq
i (strlen c)
c1 (substr c 1 (- i 1))
c2 (chr (1+ (ascii (substr c i 1))))
)
(if (or (= c2 "{") (= c2 "["))
(progn (command "erase" (entlast) "") (alert "Over character!") (exit))
(strcat c1 c2)
)
)
;;;==============================================
(defun C:OD( / cn dn c n p) ;;;Make OrDinal number with any format
(setq
cn (getstring "\nBegin at <1>: " T)
dn (getint "\nIncrement <1>: ")
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))
(setq n (vl-string-subst "" c cn))
(if (/= n "") (setq mode 1) (setq mode 0))
(while (setq p (getpoint "\nBase point <exit>: "))
(emkT cn p)
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
)
(princ)
)
;;;==============================================
(defun C:OC( / e dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from template
(setq
e (car (entsel "\nSelect template text:"))
dn (getint "\nIncrement <1>: ")
p1 (getpoint "\nBase point:")
cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point <exit>: "))
(command "copy" e "" p1 p2)
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
(setq
dat (entget (entlast))
dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(entmod dat)
)
(princ)
)
;;;==============================================
Qúa tuyệt với. Mình thường xuyên phải đánh số thứ tự trong cad. Cảm ơn bạn rát nhiều nhé
<<
|
|
Filename: 50119_od_oc.lsp
|
|
Tác giả: intelligent
Bài viết gốc: 269057
Tên lệnh: tm |
Lisp đánh số trang trong AutoCAD
Đoạn mã dưới đây tôi đã ghép thêm tổng số trang vào cuối của hàm strcat (chỗ tô màu đỏ).
>>
Đoạn mã dưới đây tôi đã ghép thêm tổng số trang vào cuối của hàm strcat (chỗ tô màu đỏ).
(DEFUN intro()(textscr)(prompt "\n Write by NGUYEN DUONG HUY - CCIC HA NOI ")(prompt "\n Ha Noi 24 -12-2005"))(intro)(defun c:tm (/ pt1 dst dir hn nn ctk te m)(setvar "cmdecho" 0 )(command ".-style" "huy" ".VnArialH" "" "" "" "" "")(command "-layer" "n" "KHUNG " "colour" "W" "KHUNG " "")(command "-layer" "s" "KHUNG" "" "")(setq pt1 (getpoint "\n Diem bat dau so thu nhat :")dst (getdist "\n Khoang cach giua cac so :")dir (getorient "\n Goc quay cua day so lieu : ")hn (getint "\n So to :"))(prompt "\n Gia tri dau tien <1>:")(setq nn (getreal))(if (null nn)(setq nn 10))(prompt "\nNhap chenh lech<1>:")(setq ctk (getreal))(if (null ctk)(setq ctk 1))(prompt "\n chieu cao chu :<1.5>")(setq m (getreal))(if (null m)(setq m 1.5))(command "text" "c" pt1 m 0 (strcat "to so " (rtos nn 2 0) <strong class='bbc'>"/" (itoa hn)</strong>))(repeat hn(setq pt1 (polar pt1 dir dst))(command "text" "c" pt1 m 0 (strcat "to so " (rtos (setq nn (+ nn ctk)) 2 0) <strong class='bbc'>"/" (itoa hn)</strong>))))
Cảm ơn anh Nguyen Hoanh đã chia sẻ để anh em khăp mọi miền tổ quốc,nâng cao trình độ chuyên muôn, nghiệp vụ!
<< |
Tác giả: envirtech2002
Bài viết gốc: 245155
Tên lệnh: ibi |
Cần tìm Lisp chèn block tại các điểm giao nhau(intersection)
Bạn thử cái này có đúng ý bạn không
(defun LM:IntersectionsinSet ( ss / a b i j l )
...
>>
Bạn thử cái này có đúng ý bạn không
(defun LM:IntersectionsinSet ( ss / a b i j l )
(setq i (sslength ss))
(while (not (minusp (setq j (1- i) i (1- i))))
(setq a (vlax-ename->vla-object (ssname ss i)))
(while (not (minusp (setq j (1- j))))
(setq b (vlax-ename->vla-object (ssname ss j))
l (cons (LM:GroupByNum (vlax-invoke a 'IntersectWith b acExtendNone) 3) l)
)
)
)
(apply 'append l)
)
(defun LM:GroupByNum ( l n / r)
(if l
(cons
(reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
(LM:GroupByNum l n)
)
)
)
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun C:ibi(/ os ss lst en pt item)
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(princ "\n Chon cac doi tuong giao nhau")
(setq
ss (ssget)
lst (LM:IntersectionsinSet ss)
en (car (entsel "\nChon Block"))
pt (dxf 10 en)
)
(foreach item lst
(command "copy" en "" pt item)
)
(setvar "osmode" os)
)
Cái này hay quá bác ah, tks bác :D
<<
|
Tác giả: tien2005
Bài viết gốc: 421369
Tên lệnh: ed |
- Tự động bật - tắt chế độ gõ tiếng việt trong CAD
Trên cơ sở version 3.0 của ThuyLinh313 mình viết lại hổ trợ cho autocad2007
;;; Tu dong bat/tat go Tieng Viet trong autocad
;;; Ho tro cho autocad 2007, duoc viet tren co so lisp cua ThuyLinh313 tai
;;; http://www.cadviet.com/forum/topic/66851-da-xong-tu-dong-bat-tat-che-do-go-tieng-viet-trong-cad/page-3
(vl-load-com)
(setq switch 0)
(if (= switch 0)
(setq switchkey "%{z}"); Alt + Z
...
>>
Trên cơ sở version 3.0 của ThuyLinh313 mình viết lại hổ trợ cho autocad2007
;;; Tu dong bat/tat go Tieng Viet trong autocad
;;; Ho tro cho autocad 2007, duoc viet tren co so lisp cua ThuyLinh313 tai
;;; http://www.cadviet.com/forum/topic/66851-da-xong-tu-dong-bat-tat-che-do-go-tieng-viet-trong-cad/page-3
(vl-load-com)
(setq switch 0)
(if (= switch 0)
(setq switchkey "%{z}"); Alt + Z
(setq switchkey "^+"); Ctrl + Shift - trung voi phim nong saveas "Ctrl + Shift + s"
)
(setq lscmd "DDEDIT,MTEDIT,TEXTEDIT,EATTEDIT")
;;;(setq lstyp "TEXT,MTEXT,DIMENSION,INSERT,ATTRIB,ATTDEF")
(setq *acdver* (atof (substr (getvar "ACADVER") 1 4)))
(cond
((>= *acdver* 21.0)(setq com1 "_textedit")); 21.0-acad2017
((<= *acdver* 19.0)(setq com1 "_ddedit")); 19.0- ACAD2013 lower
(t(ALERT(strcat"Phien ban AutoCad hien tai la "(substr (getvar "ACADVER") 1 4) "\nChua duoc khai bao")))
)
(if (= hyp-rctCmds nil)
; Add the command reactors and the custom callbacks
(setq hyp-rctCmds (vlr-command-reactor nil '((:vlr-commandCancelled . hyp-cmdAbort)
(:vlr-commandEnded . hyp-cmdAbort)
(:vlr-commandCancelled . hyp-cmdAbort)
(:vlr-commandWillStart . hyp-cmdStart)
)
)
)
)
(foreach x (cdar (vlr-reactors :vlr-mouse-reactor))
(if (= (vlr-data x) "Double-Click") (vlr-remove x)))
(vlr-mouse-reactor "Double-Click" '((:vlr-beginDoubleClick . callback-DoubleClick)))
;========================================MAIN============================================
(defun c:ed (/ textmod n-textmod ent n-ent obj n-obj l-obj font code)
(and (or (and (setq textmod (ssget "I"))
(sssetfirst textmod)
(setq obj (ssname textmod 0))
)
(setq textmod (entsel)
obj (car textmod)
)
)
(while obj
(setq ent (cdr (assoc 0 (entget obj))))
(cond
((wcmatch ent "TEXT,MTEXT,ATTDEF") ;Text,Mtext,ATTDEF
(setq font (cdr (assoc 7 (entget obj))))
(vl-cmdf com1 textmod "")
)
((= ent "DIMENSION") ;Dimension
(setq font (vla-get-textstyle (vlax-ename->vla-object obj)))
(vl-cmdf com1 textmod "")
)
((= ent "HATCH") ;Hatch
(initdia)
(vl-cmdf "_hatchedit" textmod)
)
((= ent "INSERT") ;Block
(and
(eq (type textmod) 'LIST)
(setq n-textmod (nentselp (cadr textmod)))
(setq n-obj (car n-textmod))
(setq n-ent (entget n-obj))
(setq n-obj (vlax-ename->vla-object n-obj))
(cond
((= (cdr (assoc 0 n-ent)) "ATTRIB") ; Attribute
(setq font (cdr (assoc 7 n-ent)))
;;; (setq code (check-font-code (cdr (assoc 7 n-ent))))
;;; (if (eq (vla-get-mtextattribute n-obj) :vlax-false) ;ho tro tu acad2008
;;; (progn
;;; (setq dk nil
;;; dk (sendkeys switchkey)
;;; )
;;; (cond ((= code "TCVN3") (sendkeys "^+{F2}"))
;;; ((= code "UNICODE") (sendkeys "^+{F1}"))
;;; ((= code "VNI") (sendkeys "^+{F3}"))
;;; )
;;; )
;;; )
(vl-cmdf "_eattedit" textmod)
;;; (if dk
;;; (sendkeys switchkey)
;;; )
)
((wcmatch (cdr (assoc 0 n-ent)) "TEXT,MTEXT")
; Text,Mtext in Block
(if (or extract_clone
(and (not extract_clone) (load "trexblk.lsp"))
)
(progn
(extract_clone n-textmod)
(vla-put-visible n-obj :vlax-false)
(entupd obj)
(setq l-obj (entlast)
font (cdr (assoc 7 n-ent))
)
(vl-cmdf com1 l-obj "")
(vla-put-textstring
n-obj
(cdr (assoc 1 (entget l-obj)))
)
(vla-put-visible n-obj :vlax-true)
(entdel l-obj)
(entupd obj)
)
(princ "Ban chua cai dat goi Express tool cho CAD\n")
)
)
)
)
)
) ;cond
(setq textmod (entsel)
obj (car textmod)
)
)
)
(princ)
)
;=============================================SUB================================================================
(defun hyp-cmdAbort (param1 param2 )
(if (and font (wcmatch (strcase (car param2)) lscmd))
(progn
(sendkeys switchkey)
(setq font nil)
(setvar "HIGHLIGHT" 1)
)
)
)
(defun hyp-cmdStart (param1 param2 / code)
(if (and
;;; (setq ent (cadr (ssgetfirst)))
;;; (= 1 (sslength ent))
;;; (setq ent (ssname ent 0))
;;; (wcmatch (strcase (cdr (assoc 0 (entget ent)))) lstyp)
(wcmatch (strcase (car param2)) lscmd)
font
(setq code (check-font-code font))
(cond ((= code "TCVN3") (sendkeys "^+{F2}"))
((= code "UNICODE") (sendkeys "^+{F1}"))
((= code "VNI") (sendkeys "^+{F3}"))
)
)
(sendkeys switchkey)
)
)
;;; Ham kiem tra bang ma cua textstyle (su dung true type font)
;;; style: String - ten cua textstlye kiem tra
(defun Check-Font-Code
(style / ts Bold Italic charSet PitchandFamily)
(setq ts (vlax-ename->vla-object (tblobjname "style" style)))
(vla-GetFont
ts 'font 'Bold 'Italic 'charSet 'PitchandFamily)
(if (= font "")
(setq font (vla-get-fontfile ts))
)
(cond
((wcmatch (setq font (strcase font)) ".VN*") "TCVN3")
((wcmatch font "VNI*") "VNI")
((wcmatch font
"ARIAL*,TAHOMA*,TIMES*,COURIER NEW,CAMBRIA,CONSOLAS,TCVN 7284,MICROSOFT*"
)
"UNICODE"
)
)
)
;;; Ham senkeys
(defun SendKeys (keys / wscript)
(vlax-invoke-method
(setq wscript (vlax-create-object "WScript.Shell"))
'sendkeys
keys
)
(vlax-release-object wscript)
)
;;; Ham callback lay textstyle khi Double Click vao text
(defun callback-DoubleClick (reactor point / sset obj ss objtype)
(setq sset (vla-get-selectionsets
(vla-get-activedocument (vlax-get-acad-object))
)
)
(if (vl-catch-all-error-p
(setq ss (vl-catch-all-apply 'vla-item (list sset "Tien2005")))
)
(setq ss (vla-add sset "Tien2005"))
(vla-clear ss)
)
(vla-selectatpoint
ss
(vlax-3d-point (trans (car point) 0 1))
)
(if (> (vlax-get ss 'Count) 0)
(progn
(setq obj (vla-item ss 0)
objtype (vlax-get obj 'ObjectName)
)
(if (wcmatch objtype "AcDbText,AcDbMText,AcDbAttributeDefinition")
(progn
(setq font (vla-get-stylename obj))
(sssetfirst nil (ssadd (vlax-vla-object->ename obj)))
)
(if (not (eq objtype "AcDbBlockReference"))
(sssetfirst nil (ssadd (vlax-vla-object->ename obj)))
)
)
)
)
(vla-delete ss)
)
;(setq obj (vlax-ename->vla-object (car(entsel"\nchon text"))))
<< |
Tác giả: txquychk51
Bài viết gốc: 411054
Tên lệnh: test |
Nhờ Chỉnh Sửa Text Ra Giữa Line
Cai nay` dễ mà ^_^ @Danh Cong
@txquychk
Viết nhanh cái lisp này, dùng tạm nhé ^_^
(defun...
>>
Cai nay` dễ mà ^_^ @Danh Cong
@txquychk
Viết nhanh cái lisp này, dùng tạm nhé ^_^
(defun c:test (/ osm ss p10 p11 pt p1 p2 ss_txt txt pt1)
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
(if (setq ss (ssget (list (cons 0 "LINE") (cons 8 "13.Thin"))))
(progn
(command "_zoom" "obj" ss "")
(mapcar '(lambda (obj)
(setq p10 (cdr (assoc 10 (entget obj))))
(setq p11 (cdr (assoc 11 (entget obj))))
(setq pt (polar p10 (angle p10 p11) (/ (distance p10 p11) 2)))
(setq p1 (polar p10 (/ pi 2) 4.))
(setq p2 (polar p11 (/ pi 2) 4.))
(setq ss_txt (ssget "_C" p1 p11 '((0 . "TEXT"))))
(if (not (null ss_txt))
(progn
(setq txt (ssname ss_txt 0))
(setq pt1 (list (car pt) (cadr (cdr (assoc 10 (entget txt)))) 0.0))
(vlax-put (vlax-ename->vla-object txt) 'Alignment 1)
(vlax-put (vlax-ename->vla-object txt) 'TextAlignmentPoint pt1)
);progn then
);if
)
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
(command "_zoom" "P")
)
(princ "\nBan da khong chon LINE.")
)
(setvar 'osmode osm)
(princ)
)
cảm ơn a đã quan tâm, e phải mất cả buổi để chỉnh nó, giờ có lisp thì chỉ mất mấy phút. nhưng e gặp phải vấn đề là text bị chồng lên nhau ạ (sai vị trí)
https://drive.google.com/open?id=0B5iJE54fhfEIenhlN2FEZHFMMDQ
đây là file kết quả ạ. ở cột cuối cùng, anh vào kiểm tra hộ e với ạ
<<
|
|
Filename: 411054_test.lsp
|
|
Tác giả: hochoaivandot
Bài viết gốc: 175808
Tên lệnh: par |
Dynamic Polar Array
Có cái Dynamic Array theo đường thẳng rồi, tiện thể e đi cóp nhặt thêm về cái Dynamic copy rotate theo đường tròn nữa, post lên mọi người...
>>
Có cái Dynamic Array theo đường thẳng rồi, tiện thể e đi cóp nhặt thêm về cái Dynamic copy rotate theo đường tròn nữa, post lên mọi người xài chơi.
Cho phép tăng dần đối với Text (như bản Dynamic Larray)
Mời mọi người dùng thư giãn và thanks nhé ^^ hệch hệch
Preview :
Open Source :
;Polar Array @Ketxu 22-9
;CADViet.com
;Many thank to qjchen again
(vl-load-com)
(defun c:par( / ang angnow gr oang p0 px px1 ss ss1 cc oldAng ans)
(grtext -1 "Dynamic PArray @Ketxu")
(setq m:err *error* *error* err)
(command "undo" "be")
(setq oldAng (getvar "angbase"))
(if (and
(setq ss (ST:SS->List-Vla (ssget))
p0 (getpoint "\nT\U+00E2m quay : :")
px (getpoint p0 "\n\U+0110\U+01B0\U+1EDDng c\U+01A1 s\U+1EDF ::")
)
)
(progn
(grdraw p0 px 1)
(setvar "angbase" (angle p0 px))
(setq cc (_circle p0 (distance p0 px))
ang (getangle p0 "\nG\U+00F3c Array :")
s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE")))
)
(cond ((ST:Check-Exist '("AcDbText" "AcDbMText") (mapcar 'vla-get-objectname ss))
(setq ans (strcase(getstring "Copy t\U+0103ng Text ? < K > :")))
(cond ((not (or (= ans "K")(= ans "")))
(or #num (setq #num 1))
(setq #num (cond ((getint (strcat "\nGia s\U+1ED1 < " (rtos #num 2 0) " > :")))(#num)) inc T)
)
)
)
)
(prompt "\nPick \U+0111i\U+1EC3m cu\U+1ED1i c\U+00F9ng :")
(while (= (car (setq gr (grread nil 5 0))) 5)
(if ss1 (mapcar 'vla-delete ss1))
(redraw)
(setq angnow (angle p0 (cadr gr))
g (trans (cadr gr) 1 3)
)
(grvecs (LM:GrText (rtos (/ (* angnow 180) pi) 2 0) 3)
(
(lambda ( r x y )
(list
(list r 0. 0. x )
(list 0. r 0. y )
(list 0. 0. r 0.)
(list 0. 0. 0. 1.)
)
)
s
(+ (car g) (* 15 s))
(- (cadr g) (* 31 s))
)
)
(if (and (< ang 0)(> angnow 0)) (setq angnow (- angnow (* 2 pi))))
(if (and (> ang 0)(< angnow 0)) (setq angnow (+ (* 2 pi) angnow)))
(setq ss1 (_copyCC ss (fix (/ angnow ang)) p0 ang inc #num))
(grdraw:arc p0 (/ (getvar "viewsize") 4.0) (angle p0 px) angnow)
)
(entdel cc)
;(setvar "angbase" oldAng)
)
)
(command "undo" "en")
(princ)
)
;;; =======================================================================;
;;; by qjchen, copy ss according to the direction and vector ;
;;; =======================================================================;
(defun _copyCC (sslst n cen ang inc num / i obj1 ss xobj lst number)
(foreach xobj sslst
(setq i 1)
(cond ((and (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
(cond ((= 'REAL (type (setq number (last (setq lst (ST:String-GetNumber (vla-get-textstring xobj)))))))
(setq isReal T))
(T (setq isReal nil))
)
(setq isText T)
) ;Text Object
(T setq isText nil)
)
(repeat n
(setq obj1 (vla-copy xobj))
(Vla-rotate obj1 (vlax-3d-point cen) (* ang i))
(if (and isText (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
(vla-put-textstring obj1 (strcat (car lst) (rtos (setq number (+ num number)) 2 (if isReal 1 0))(cadr lst))))
(setq i (1+ i) ss (cons obj1 ss))
)
)
ss
)
;;; =======================================================================;
;;; @Ketxu Make Circle Temp ;
;;; =======================================================================;
(defun _circle (p0 r / ent)
(redraw (setq ent(entmakex (list (cons 0 "CIRCLE")(cons 10 (trans p0 1 0))(cons 40 r)))) 3) ent)
(defun RtD (rad) ; converts radian to degree
(/ (* rad 180) pi)
);defun
;;; =======================================================================;
;;; Check List Item Exist in Other List @Ketxu ;
;;; =======================================================================;
(defun ST:Check-Exist(lst1 lst2)(and (vl-remove nil (mapcar '(lambda(x)(vl-position x lst2)) lst1))))
;;; =======================================================================;
;;; Selection to list VLA @Ketxu ;
;;; =======================================================================;
(defun ST:SS->List-Vla (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
)
)
(defun ST:Ss-Delete (ss / i)
(mapcar 'vla-delete (ST:SS->List-Vla ss))
)
;;; =======================================================================;
;;; grdraw circle arc ;
;;; =======================================================================;
(defun grdraw:arc(cen r ang angadd / angdiv n)
(grdraw cen (polar cen ang r) 3 1)
(grdraw cen (polar cen (+ ang angadd) r) 3 1)
(setq n 100 angdiv (/ angadd n))
(repeat n
(grdraw (polar cen ang r)(polar cen (setq ang (+ ang angdiv)) r) 1 1)
)
)
(defun ST:String-GetNumber (str / i j dau cuoi tmp tmp1 tmp2 num)
(setq lst (vl-string->list str) i -1 j (strlen str))
(list
(setq tmp1 (vl-list->string (reverse (while (not (or (<= 48 (setq tmp (nth (setq i (1+ i)) lst)) 57) (>= i j))) (setq dau (cons tmp dau))))))
(setq tmp2(vl-list->string (while (not (or (<= 48 (setq tmp (nth (setq j (1- j)) lst)) 57) (<= j i))) (setq cuoi (cons tmp cuoi)))))
(if (vl-string-search "." (setq num (vl-string-left-trim tmp1 (vl-string-right-trim tmp2 str)))) (atof num) (atoi num))
)
)
;;; =======================================================================;
;;; Error del selection @Ketxu ;
;;; =======================================================================;
(defun err (msg)
(if ss1 (mapcar 'vla-delete ss1))
(if cc (entdel cc))
(if oldAng (setvar "angbase" oldAng))
(setq *error* m:err m:err nil)
)
(defun LM:GrText ( str col / c i l v y ) ;@Lee Mac
(setq v
'(
(" ")
("\t")
("!" 45 45 65 135)
("\"" 104 134 107 137)
("#" 43 63 46 66 84 94 87 97 115 135 118 138 72 78 103 109)
("$" 25 35 52 52 43 47 58 78 83 87 92 112 123 127 118 118 135 135)
("%" 52 52 63 63 74 74 85 85 96 96 107 107 118 118 129 129 47 48 67 68 56 56 59 59 113 114 133 134 122 122 125 125)
("&" 43 46 49 49 52 72 57 58 67 68 76 76 79 79 83 83 85 85 94 94 103 123 134 136 127 127)
("'" 105 135)
("(" 17 17 26 36 45 105 116 126 137 137)
(")" 14 14 25 35 46 106 115 125 134 134)
("*" 73 74 76 77 84 86 92 98 104 106 113 114 116 117)
("+" 55 115 82 84 86 88)
("," 34 35 45 46 55 57)
("-" 83 88)
("." 45 46 55 56)
("/" 52 52 63 63 74 74 85 85 96 96 107 107 118 118 129 129)
("0" 44 47 134 137 53 123 58 128)
("1" 44 48 124 125 56 136)
("2" 43 48 53 53 64 64 75 75 86 86 97 97 108 128 134 137 123 123)
("3" 53 53 44 47 58 88 95 97 108 128 134 137 123 123)
("4" 46 48 57 137 78 78 73 76 83 83 94 94 105 115 126 126)
("5" 53 53 44 47 58 88 94 97 93 133 134 138)
("6" 44 47 58 88 95 97 84 84 53 113 124 124 135 137)
("7" 44 54 65 75 86 96 107 117 128 138 133 137 123 123)
("8" 44 47 94 97 134 137 53 83 58 88 103 123 108 128)
("9" 44 46 57 57 68 128 97 97 84 86 134 137 93 123)
(":" 45 46 55 56 95 96 105 106)
(";" 34 35 45 46 55 57 95 96 105 106)
("<" 47 47 56 56 65 65 74 74 83 83 94 94 105 105 116 116 127 127)
("=" 73 78 93 98)
(">" 43 43 54 54 65 65 76 76 87 87 96 96 105 105 114 114 123 123)
("?" 45 45 65 75 86 86 97 97 108 128 134 137 123 123)
("@" 34 38 43 43 52 112 123 123 134 137 128 128 79 119 68 68 65 66 105 106 77 107 74 94)
("A" 41 43 47 49 52 62 58 68 73 77 83 93 87 97 104 114 106 116 125 135 133 134)
("B" 42 47 53 123 58 88 108 128 94 97 132 137)
("C" 44 47 53 53 58 58 62 112 123 123 134 136 127 127 108 138)
("D" 42 46 57 57 127 127 132 136 68 118 53 123)
("E" 42 48 58 58 94 95 86 106 132 137 128 138 53 123)
("F" 42 45 94 95 86 106 132 137 128 138 53 123)
("G" 44 47 53 53 58 78 86 89 62 112 123 123 134 136 127 127 108 138)
("H" 41 43 47 49 131 133 137 139 93 97 52 122 58 128)
("I" 43 47 133 137 55 125)
("J" 52 62 43 46 57 127 135 139)
("K" 42 44 48 49 132 134 136 138 53 123 84 85 95 95 106 116 127 127 76 76 67 67 58 58)
("L" 42 47 48 58 53 123 132 135)
("M" 41 43 47 49 52 122 58 128 131 132 138 139 103 113 107 117 84 94 86 96 65 75)
("N" 41 44 131 132 136 139 52 122 48 128 113 113 94 104 85 85 66 76 57 57)
("O" 44 46 53 53 57 57 123 123 127 127 134 136 62 112 68 118)
("P" 42 45 84 87 132 137 53 123 98 128)
("Q" 134 136 123 123 127 127 112 62 118 68 53 53 57 57 44 46 35 36 23 24 27 28)
("R" 42 44 48 49 132 137 123 53 128 98 84 87 76 76 67 67 58 58)
("S" 42 62 53 53 44 47 58 78 86 87 93 95 102 122 133 136 127 127 118 138)
("T" 43 47 55 125 132 138 131 121 139 129)
("U" 44 46 52 53 57 58 62 122 68 128 131 133 137 139)
("V" 45 55 64 74 66 76 83 103 87 107 112 122 118 128 131 133 137 139)
("W" 43 63 47 67 72 92 74 94 76 96 78 98 101 121 105 115 109 129 131 132 138 139)
("X" 41 43 47 49 131 133 137 139 52 52 58 58 63 63 67 67 74 74 76 76 85 95 104 104 106 106 113 113 117 117 122 122 128 128)
("Y" 43 47 55 85 94 94 96 96 103 113 107 117 122 122 128 128 131 133 137 139)
("Z" 122 122 58 58 132 138 42 48 128 128 52 52 63 63 74 74 85 95 106 106 117 117)
("" 14 16 134 136 26 126)
("^" 102 102 113 113 124 124 135 135 126 126 117 117 108 108)
("_" 21 29)
("`" 125 125 134 134)
("a" 43 46 48 48 52 72 57 97 83 86 103 106)
("b" 42 43 45 46 54 54 57 58 68 98 97 97 105 106 94 94 132 132 53 133)
("c" 44 46 53 53 57 58 52 92 93 93 104 106 97 98 108 108)
("d" 44 45 47 48 52 92 53 53 56 56 93 93 104 105 96 96 136 136 57 137)
("e" 44 46 53 53 57 58 52 92 93 93 104 106 97 98 88 88 73 78)
("f" 43 46 54 124 93 93 95 96 135 137 128 128)
("g" 13 16 22 32 27 97 107 108 66 66 96 96 54 55 104 105 63 63 93 93 62 92)
("h" 42 44 46 48 57 97 53 133 132 132 94 94 105 106)
("i" 43 47 55 105 103 104 135 135)
("j" 22 22 13 15 26 106 104 105 136 136)
("k" 42 44 46 48 53 133 132 132 57 57 66 66 74 75 85 85 96 106 107 108)
("l" 43 47 55 135 133 134)
("m" 41 43 45 46 48 49 52 102 55 105 58 108 101 101 93 93 104 104 96 96 107 107)
("n" 42 44 46 48 53 103 57 97 102 102 94 94 105 106)
("o" 44 46 104 106 53 53 57 57 93 93 97 97 52 92 58 98)
("p" 12 15 23 103 102 102 54 54 94 94 45 46 105 106 57 58 97 98 68 88)
("q" 15 18 27 107 108 108 56 56 96 96 44 45 104 105 52 53 92 93 62 82)
("r" 42 46 54 104 102 103 95 95 106 108 99 99)
("s" 52 52 43 47 58 68 73 77 82 92 103 107 98 98)
("t" 45 47 58 58 54 124 102 103 105 107)
("u" 102 102 106 106 53 103 56 56 44 45 47 107 48 48)
("v" 45 45 54 64 56 66 73 83 77 87 92 92 98 98 101 103 107 109)
("w" 43 53 47 57 62 92 64 84 66 86 68 98 101 103 95 105 107 109)
("x" 42 44 46 48 102 104 106 108 53 53 57 57 93 93 97 97 64 64 66 66 84 84 86 86 75 75)
("y" 12 13 24 24 35 45 54 64 56 66 73 83 77 87 92 92 98 98 101 103 107 109)
("z" 92 92 58 58 102 108 42 48 97 97 86 86 75 75 64 64 53 53)
("{" 16 17 25 65 73 74 85 125 136 137)
("|" 15 135)
("}" 14 15 26 66 77 78 86 126 134 135)
("~" 112 122 133 134 125 125 116 117 128 138)
)
)
(eval
(list 'defun 'LM:GrText '( str col / c i l v y )
(list 'setq 'v
(list 'quote
(mapcar
(function
(lambda ( b )
(cons (car B) (mapcar '(lambda ( a ) (if a (list (rem a 10) (/ a 10)))) (cdr B)))
)
)
v
)
)
)
'(setq i 0 y 0)
'(repeat (strlen str)
(cond
( (eq (setq c (substr str 1 1)) " ")
(setq i (+ i 9) str (substr str 2))
)
( (eq c "\t")
(setq i (+ i 36) str (substr str 2))
)
( (eq c "\n")
(setq i 0 y (- y 16) str (substr str 2))
)
( (setq l
(cons
(mapcar
(function
(lambda ( a )
(if a (list (+ (car a) i) (+ (cadr a) y)))
)
)
(cdr (assoc c v))
)
l
)
str (substr str 2) i (+ i 9)
)
)
)
)
'(cons col (apply 'append l))
)
)
(LM:GrText str col)
)
Chào ketxu!
Lisp của ketxu rất hay, mình đã học được rất nhiều.
Mình hỏi Ketxu 1 vấn đề có liên quan đến GRREAD.
Đối với các hàm getxxx thì mình dùng initget để có các lựa chọn input khác. Vậy thằng Grread này có chức năng tương tự không ketxu?
Chẳng hạn như trong Lisp của ketxu, người dùng kéo rê chuột để chọn số lượng array; Có thể nào thêm lựa chọn khác để nhập, tỉ nhỉ bấm A để nhập góc tổng, bấm N để nhập trựctiếp số lượng ARRAY. Nếu không phải 2 lựa chọn trên thì kéo rê.
Mình nói rõ thêm là phương án kéo rê chuột ưu tiên không cần nhập Keyword, có 2 cách nhập kia mới nhập keyword.
Mình search vấn không có cách!
<<
|
Tác giả: hoquangvinh
Bài viết gốc: 410329
Tên lệnh: sumdim1 |
Cộng Tất Cả Các Demension Trong Một Layer
Đã thêm trường hợp Dim sửa số và đã test.
Còn dim mà thêm các hậu tố tiền tố linh cu tinh thì trong trường hợp này...
>>
Đã thêm trường hợp Dim sửa số và đã test.
Còn dim mà thêm các hậu tố tiền tố linh cu tinh thì trong trường hợp này chắc không dùng. ^_^ Nếu cần dùng thì post chi tiết bản vẽ để mọi người check cho nhé.
(defun c:sumdim1 (/ ss layer)
(vl-load-com)
(if (and (setq ss (car (entsel "\nChon 1 dim dien hinh layer: ")))
(eq (cdr (assoc 0 (entget ss))) "DIMENSION")
) ;and
(progn
(setq ss (ssget "_X"
(list (cons 0 "DIMENSION")
(setq layer (assoc 8 (entget ss)))
)
)
) ;setq
(alert
(strcat "Total Dim layer <"
(cdr layer)
">: "
(vl-princ-to-string
(apply '+
(mapcar '(lambda (vla)
(if (= "" (vlax-get vla 'TextOverride))
(vlax-get vla 'Measurement)
(distof (vlax-get vla 'TextOverride))
)
)
(mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex ss))
)
)
)
)
)
)
)
) ;progn then
(princ "\nBan da khong chon dim.!")
)
(princ)
)
(princ)
Mình check thấy lisp chạy tốt rồi nhưng nếu thêm lựa chọn một chút nữa sẽ hay hơn
-1. Tên lệnh
-2. Chọn dim mẫu
-3. Quét chọn các dim cần tính
-4. Thực hiện lệnh ra kết quả
Vậy là thêm lựa chọn thứ 3 nữa thì lisp sẽ thuận lợi khi sử dụng hơn
Ps: bạn @Bee là lisper mới nối nhé, rất hot đây
<<
|
|
Filename: 410329_sumdim1.lsp
|
|
Tác giả: quocmanh04tt
Bài viết gốc: 354140
Tên lệnh: layon |
Cần xin Lisp ẩn và hiện tất cả các layer!!!
Bạn thử xem sao:
(defun c:layon ()
(vlax-for each (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(vla-put-layeron each :vlax-true))
(princ))
(defun c:layoff (/ ss i)
(if (setq ss (ssget))
(repeat (setq i (sslength ss))
(vla-put-layeron (vlax-ename->vla-object
(tblobjname "LAYER" (vla-get-layer (vlax-ename->vla-object (ssname ss (setq i (1- i)))))))
:vlax-false)))
(princ))
|
|
Filename: 354140_layon.lsp
|
|
Tác giả: trungkscd
Bài viết gốc: 172133
Tên lệnh: tbkd |
lisp vẽ đường bóng ( đường thể hiện dốc trên mặt bằng )
Mình đưa ra 1 ví dụ để bạn thấy việc viết lisp không đơn giản, và nếu người yêu cầu không biết mình cần gì, sẽ không bao giờ có...
>>
Mình đưa ra 1 ví dụ để bạn thấy việc viết lisp không đơn giản, và nếu người yêu cầu không biết mình cần gì, sẽ không bao giờ có đáp án, hoặc chí ít cũng không được như ý
(defun c:tbkd(/ eLine curve1 curve2 i j len1 len2 tmp)
(vl-load-com)
(or #dist (setq #dist 10)) ; 10 = Khoang cach mac dinh
(setq #dist (cond ((getdist (strcat "\nKhoang cach bat dau <" (vl-princ-to-string #dist) " > :")))(#dist)))
(or #inc (setq #inc 1.2)) ;
(setq #inc (cond ((getdist (strcat "\nGia so <" (vl-princ-to-string #inc) " > :")))(#inc)))
(defun eLine (p1 p2 / p2 col)(entmake (list (cons 0 "LINE")(cons 10 p1) (cons 11 p2)(cons 62 8) (cons 8 "0"))))
;;Doan duoi nay khong can de y
(If
(and
(setq curve1 (car(entsel "\nPath curve 1 :")))
(setq curve2 (car(entsel "\nPath curve 2 :")))
(wcmatch (cdadr (entget curve1)) "*LINE,ARC")
(wcmatch (cdadr (entget curve2)) "*LINE,ARC")
(eLine (vlax-curve-getStartPoint curve1) (vlax-curve-getStartPoint curve2))
(setq tmp 0 i 0 len1 (vlax-curve-getDistAtParam curve1 (vlax-curve-getEndParam curve1)) len2 (vlax-curve-getDistAtParam curve2 (vlax-curve-getEndParam curve2)))
)
(while (<= (setq tmp (+ (* #dist (expt #inc (setq i (1+ i))))tmp)) len1)
(eLine (vlax-curve-getPointAtDist curve1 tmp) (vlax-curve-getPointAtDist curve2 tmp))
)
)
)
.......................////
e thay lisp nay hay. Nhung no chi ve khi co 2 culve song song nhau , con 1 duong thang va 1 duong cheo ko ve vuong goc duoc
anh KETXU co the hieu chinh them chut nua la ok
<<
|
|
Filename: 172133_tbkd.lsp
|
|