Info | File |
Tác giả: Bee
Bài viết gốc: 409826
Tên lệnh: mb |
Lisp Tạo Text
thanks bạn duy782006 !
Nhờ bạn mà mình đã tìm ra được nguyên nhân bị lỗi font và...
>>
thanks bạn duy782006 !
Nhờ bạn mà mình đã tìm ra được nguyên nhân bị lỗi font và mình cũng đã tạo được lsp này:
(DEFUN C:MB (/ TILE P)
(IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
(command ".STYLE" "ARIAL" "ARIAL TUR" "" "" "" "" "" "")
)
(SETQ
tile (getint "\nTi le: ")
p (getpoint "\nDiem dat text: ")
)
(COMMAND "TEXT" "S" "ARIAL" "J" "TL" P (* TILE 2) "0" "%%UM\U+1EB6T B\U+1EB0NG TÔN MÁI"
"TEXT" "S" "ARIAL" "J" "TL" (POLAR P (/ PI -2) (* 3.5 TILE )) (* TILE 1.5) "0" "%%UM\U+1EB6T B\U+1EB0NG MÓNG"
)
)
Và mình chưa hiểu các bỏ dấu kiểu này nên nhờ bạn chỉ mình cách bỏ dấu kiểu này với:
M\U+1EB6T B\U+1EB0NG : MẶT BẰNG
Cái này là unicode chứ có phải vni đâu. Topic trước thì hỏi 1 kiểu. heizz. Lầu sau gửi cả file CAD để mọi người check vấn đề giúp cho nhanh. Kiến thức có hạn mà hỏi loanh quanh chỉ mất thời gian mà không hiệu quả.
<<
|
Tác giả: t031285
Bài viết gốc: 154859
Tên lệnh: df |
Hiệu chỉnh Dt Text??????
Cám ơn anh Duy. Em dựa vào chính đoạn Code mà anh Duy đã viết cho bạn hhhhgggg để đổi font cho text sang font .VnHelvetlnsH.
Như các bạn đã...
>>
Cám ơn anh Duy. Em dựa vào chính đoạn Code mà anh Duy đã viết cho bạn hhhhgggg để đổi font cho text sang font .VnHelvetlnsH.
Như các bạn đã biết khi ta đánh lệnh Style và thiết lập cho font chữ style đó là font chữ đậm thì nó tác dụng lên toàn bộ Text của Style đó. Còn muốn tô chữ đậm cho text riêng lẻ thì sử dụng đoạn Code của anh Duy và thay cái chuỗi ".VnHelvetInsH Medium" bằng textstyle tô đậm thích hợp là được.
(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" ".VnHelvetInsH Medium" "0" "1" "0" "n" "n")
(prompt "\nChon chu muon chinh.")
(setq ss (ssget))
(setq c 0)
(if ss (setq e (ssname ss c)))
(while e
(setq e (entget e))
(if (= (cdr (assoc 0 e)) "TEXT")
(progn
(setq txt "doifont")
(setq e (subst (cons 7 txt) (assoc 7 e) e))
(entmod e)
)
)
(setq c (1+ c))
(setq e (ssname ss c))
)
(command "undo" "end")
(Princ)
)
Ví dụ :
Để đổi sang font chữ :
.VnArial (Regular) : Thì thay cái chuỗi ".VnHelvetInsH Medium" bằng chuỗi : "VNARIAL.TTF"
.VnArial (Bold) (Chữ đậm) : Thì thay cái chuỗi ".VnHelvetInsH Medium" bằng chuỗi : "VNARIALB.TTF"
.VnArial (Italic) (Chữ nghiêng) : Thì thay cái chuỗi ".VnHelvetInsH Medium" bằng chuỗi : "VNARIALI.TTF"
.VnArial (Bold Italic) (Chữ đậm nghiêng) : Thì thay cái chuỗi ".VnHelvetInsH Medium" bằng chuỗi : "VNARIABI.TTF"
Như vậy, bạn phải xác định truớc font chữ của Style đó rồi mới tô thành cái chữ đậm được.
Anh Duy cho thêm ý kiến nhé. Cảm ơn.
Vậy mình muốn font vni-helve-Condense (bold) thì thay bằng chuỗi gì?Thanks.
<<
|
Tác giả: Phiphi-
Bài viết gốc: 91709
Tên lệnh: b2r |
Insert nhiều file DWG một lúc!
lisp B2R (block to rectangle) dưới đây sẽ giúp Phiphi:
(defun c:b2r ()
(setq ss (ssget '((0 . "INSERT"))))
(while (setq e (ssname ss 0))
(setq ss (ssdel e ss)
...
>>
lisp B2R (block to rectangle) dưới đây sẽ giúp Phiphi:
(defun c:b2r ()
(setq ss (ssget '((0 . "INSERT"))))
(while (setq e (ssname ss 0))
(setq ss (ssdel e ss)
tmp (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p3)
p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p1 (list (car p1) (cadr p1))
p3 (list (car p3) (cadr p3))
p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
tmp (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
)
)
(entmake tmp)
)
)
Chào bác Nguyen Hoanh.
Bác có thể nhập đoạn code trên chung với MPLOT được không.
Như vậy User chỉ cần select các bản vẽ cần in ra hàng loạt mà khỏi phải chọn block khung tên hoặc Rectangle.
Chỉ cần đoạn code trên insert các Rectangle cho việc in xong rồi sẽ tự động xoá đi.
Bản vẽ Multiple drawings mà PP up trên không thể chọn block khung tên để in hàng loạt được.
Bác có phát hiện vì sao không vậy? Các khung tên trên là của AutoDesk tạo để dùng cho các templates trong p/m AutoCAD.
<<
|
Tác giả: ui_troi_2005
Bài viết gốc: 52764
Tên lệnh: scc chd xy cl l1 ll lto |
Tiện ích nhỏ về kích thước và đo đạc
1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure:
;;;=================================
;;;SMALL UTILITIES FOR DIMENSIONS...
>>
1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure:
;;;=================================
;;;SMALL UTILITIES FOR DIMENSIONS AND MEASUREMENTS
;;;CAC TIEN ICH NHO VE KICH THUOC VA DO LUONG
;;;=================================
;;;HUONG DAN:
;;;SaveAs *.lsp, go lenh Appload, go cac lenh sau day de chay:
;;;-------------------------------------------------------------
;;;1- Lenh SCC: SCale with Constant dimensions
;;;Hoat dong nhu lenh Scale cua AutoCAD nhung giu nguyen gia tri Dim
;;;(chi co "Dim Scale Linear" va "Dim Scale Overall" thay doi)
;;;Cac thuoc tinh khac cua Dim khong bi anh huong
;;;Tuy chon Dim Scale Overall = Y cho phep scale ca cac yeu to khac cua Dim
;;;(text, kich thuoc mui ten, khoang nho ra cua duong giong...)
;;;Mac dinh la Dim Scale Overall = N
;;;Chap nhan cac Dim co DimStyle khac nhau
;;;-------------------------------------------------------------
;;;2- Lenh CHD: CHeck Dimensions
;;;Kiem tra toan bo cac doi tuong Dimensions co trong ban ve
;;;Dim bi edit bang Text Override se chuyen sang layer DimCheck co mau RED
;;;-------------------------------------------------------------
;;;3- Lenh XY: ghi toa do X, Y cua diem pick
;;;Ket qua ghi dang Leader va 1 Mtext co 2 dong
;;;-------------------------------------------------------------
;;;4- Lenh CL: ve Center Line cho duong tron tai layer CEN
;;;Neu Layer khong ton tai, chuong trinh tu tao layer CEN
;;;Voi thiet lap mau Magenta, Ltype ACAD_ISO04W100
;;;-------------------------------------------------------------
;;;5- Lenh L1: Do va ghi chieu dai 1 doi tuong, vi tri dat text do user chon
;;;-------------------------------------------------------------
;;;6- Lenh LL: Do va ghi chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Vi tri dat text tai diem giua cua tung doi tuong
;;;-------------------------------------------------------------
;;;7- Lenh LTO: Do va ghi tong chieu dai nhieu doi tuong, user chon vi tri dat text
;;;-------------------------------------------------------------
;;;GHI CHU CHUNG VOI KET QUA GHI DANG TEXT
;;;Chuong trinh dung TextStyle hien hanh de ghi ket qua
;;;So chu so thap phan phu thuoc thiet lap Units
;;;Vao Format -> Units -> chon Precision tuy y
;;;-------------------------------------------------------------
;;;Copyright by ssg - www.cadviet.com - March 2009
;;;=================================
;;;PUBLIC FUNCTIONS
;;;=================================
(defun getL(e) ;;;Get Length of curve e
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;-------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
(list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss)
(setq
e (ssname ss i)
Le (append Le (list e))
i (1+ i)
)
)
Le
)
;;;-------------------------------------------------------------
(Defun Bdraw()
;;;Begin draw, get some current system variables, disable them
(setq OldOs (getvar "osmode"))
(setq OldLay (getvar "clayer"))
(setvar "osmode" 0)
)
;;;-------------------------------------------------------------
(Defun Edraw()
;;;End draw, reset all system variables
(setvar "osmode" OldOs)
(setvar "clayer" OldLay)
)
;;;-------------------------------------------------------------
(Defun SetLayer(MyLayer)
;;;Make and Set Layer
(if (not (tblsearch "LAYER" MyLayer)) (progn
(Cond
((= (strcase MyLayer) "0") (setq MyColor "White" MyLtype "Continuous"))
((= (strcase MyLayer) "CEN") (setq MyColor "Magenta" MyLtype "ACAD_ISO04W100"))
((= (strcase MyLayer) "DIM") (setq MyColor "Green" MyLtype "Continuous"))
((= (strcase MyLayer) "HATCH") (setq MyColor "Yellow" MyLtype "Continuous"))
((= (strcase MyLayer) "HID") (setq MyColor "Cyan" MyLtype "ACAD_ISO02W100"))
((= (strcase MyLayer) "STT") (setq MyColor 140 MyLtype "Continuous"))
((= (strcase MyLayer) "KHUNGTEN") (setq MyColor 120 MyLtype "Continuous"))
)
(Command "Layer" "N" MyLayer "L" MyLtype MyLayer "C" MyColor MyLayer "T" MyLayer "")
))
(setvar "CLayer" MyLayer)
)
;;;=================================
;;;DIMENSION AND GEOMETRIC COMMAND FUNCTIONS
;;;=================================
(defun SCDim( / e ob OName SF LSF)
(while (setq e (ssname ssd 0))
(setq
ob (vlax-ename->vla-object e)
OName (vla-get-ObjectName ob)
SF (vla-get-ScaleFactor ob)
)
(if (not (wcmatch OName "*AngularDimension"))
(progn
(setq LSF (vla-get-LinearScaleFactor ob))
(command "dimoverride" "dimlfac" (/ LSF k) "" e "")
)
)
(if (/= opt "N") (command "dimoverride" "dimscale" (* SF k) "" e ""))
(ssdel e ssd)
)
)
;;;-------------------------------------------------------------
(defun C:SCC( / ss ssd p k opt) ;;;SCale with Constant dimensions
(vl-load-com)
(setq
ss (ssget)
ssd (ssget "p" '((0 . "DIMENSION")))
p (getpoint "\nBase point:")
k (getreal "\nScale Factor:")
opt (strcase (getstring "\nDim scale overall? :"))
)
(if (= opt "") (setq opt "N"))
(if (> k 1)
(progn (command "scale" ss "" p k) (SCDim))
(progn (SCDim) (command "scale" ss "" p k))
)
(princ)
)
;;;=================================
(defun C:CHD( / ss e txt n) ;;;CHeck Dimensions
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch "layer" "DimCheck"))
(command "Layer" "N" "DimCheck" "C" "Red" "DimCheck" "")
)
(while (setq e (ssname ss 0))
(setq txt (cdr (assoc 1 (entget e))))
(if (not (or (= txt "") (vl-string-search "<>" txt))) (progn
(command "change" e "" "p" "LA" "DimCheck" "")
(setq n (1+ n))
))
(ssdel e ss)
)
(if (= n 0) (setq S "Ket qua check: OK")
(setq S (strcat "Co " (itoa n) " Dimensions bi sua Text Override"
"\nDa duoc chuyen sang layer DimCheck co mau RED!")
)
)
(alert S)
(princ)
)
;;;=================================
(defun C:XY( / p1 p2)
(setq
p1 (getpoint "\nFirst point:")
p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X=" (rtos (car p1)) "\\PY=" (rtos (cadr p1))) "")
(princ)
)
;;;=================================
(defun C:CL(/ p r p1 p2 p3 p4 oldos oldlay) ;;;Center Line duong tron
(setq
p (getpoint "\nCenter point:")
oldOrtho (getvar "orthomode")
)
(setvar "orthomode" 1)
(setq r (getdist p "\nEnd point: "))
(Bdraw)
(SetLayer "CEN")
(command "line" (polar p pi r) (polar p 0 r) "")
(command "line" (polar p (/ pi 2) r) (polar p (/ pi -2) r) "")
(setvar "orthomode" oldOrtho)
(Edraw)
(princ)
)
;;;=================================
(defun C:L1( / e L) ;;;Do va ghi chieu dai 1 doi tuong
(setq e (car (entsel "\nSelect object:")))
(command "lengthen" e "")
(setq L (getvar "perimeter"))
(wtxt (strcat "L= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================
(defun Measure1(e / L p)
(vl-load-com)
(setq
L (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
p (vlax-curve-getPointAtDist e (/ L 2))
)
(wtxt (strcat "L= " (rtos L)) p)
)
;;;-------------------------------------------------------------
(defun C:LL( / ss e) ;;;Do chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Ket qua ghi tai diem giua cua tung doi tuong
(setq ss (ssget '((0 . "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))))
(while (setq e (ssname ss 0))
(measure1 e)
(ssdel e ss)
)
)
;;;=================================
(defun C:LTO( / ss Le L e L1) ;;;Do va ghi tong chieu dai nhieu doi tuong
(setq
ss (ssget '((0 . "LINE,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")))
Le (ss2ent ss)
L 0
)
(foreach e Le (setq L (+ L (getL e))))
(wtxt (strcat "Lt= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================
2- Có vấn đề gì về sử dụng, các bạn phản hồi để ssg sửa
3- Cần bổ sung thêm những tiện ích gì thuộc dạng này không?
Chào bác SSQ.
các lisp bác đưa lên thật tuyệt vời, em cảm ơn bác nhiều lắm.
nhưng em có một thắc mắc nhỏ là cái lệnh LTO đó nó luông luôn tính tổng ở tỉ lệ 1:1, nếu bản vẽ vẽ ở tỉ lệ khác thì nó ko theo tỉ lệ đó, trong khi đó các kthước đo ở tỉ lệ đó vànhư vậy có mâu thuẫn giữa kthước và tổng kthước, mong bác xem lại và có thể cho bản tính tỏng đó hoànthiện hơn.
Rất cảm ơn bác.
<<
|
Filename: 52764_scc_chd_xy_cl_l1_ll_lto.lsp
|
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440593
Tên lệnh: te |
Xử Lý Text Trong Autocad
12 giờ trước, Nguyen Huy Hanh đã nói:
12 giờ trước, Nguyen Huy Hanh đã nói:
Bạn thấy mỗi dòng có 1 nội dung khác nhau mà chỉ lấy từ bên phải ghép sang bên trái như thế mà dùng lệnh Find rất phức tạp. Mà thay đổi Phần bên phải thì vị trí nó không đúng.
Sorry bạn, lúc đầu đọc cứ tưởng đổi abc thành abcd.
Nếu các text cùng hàng thì mình viết cho bạn lisp này sẽ nhanh hơn là pick từng text như bạn viết.
(defun c:te (/ ss ent1 ent2 str1 str2 str)
(prompt "\nQuet chon vung chua cac text")
(or (setq ss (acet-ss-to-list (ssget (list (cons 0 "*TEXT"))))) (exit))
(setq ss (vl-sort ss '(lambda (x y) (cond ( (= (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))) )
(< (cadr (assoc 10 (entget x))) ) (cadr (assoc 10 (entget y))))
((> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))) ))))
(while (and (setq ent1 (car ss))
(setq ent2 (cadr ss)))
(setq str1 (cdr (assoc 1 (entget ent1)))
str2 (cdr (assoc 1 (entget ent2))))
(setq str (strcat (vl-string-right-trim "0123456789" str1) (substr str2 (1+ (strlen (vl-string-right-trim "0123456789" str2))))))
(entmod (subst (cons 1 str) (assoc 1 (entget ent1)) (entget ent1)))
(setq ss (cddr ss))
)
)
<<
|
Tác giả: Tue_NV
Bài viết gốc: 440635
Tên lệnh: nb |
(NHỜ VIẾT LISP)
Cái nào cũng phải có khoảng cách mới array. Chứ không có khoảng cách thì array thế nào được
Quick code cho bạn (khoảng cách nhập = khoảng cachs nan + khe
(defun c:nb()
(setq ss (ssget))
(setq kc (getreal "\khoang cach nan + khe : "))
(setq nan (getint "\n Nhap so nan :"))
(command "._Array" ss "" "R" "C" nan "1" "S" kc "")
)
|
Tác giả: duythanhxda
Bài viết gốc: 193872
Tên lệnh: chon |
Lisp chọn tất cả các đối tượng thuộc 1 layer !
Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn...
>>
Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn layer 0
(defun c:chon()(sssetfirst nil (ssget "x" '((8 . "0")))))
Mình đã dùng lisp SCT và lisp CHON để scale tất cả hình tròn thành công và rất cảm ơn các bạn,rất hay và hữu ích..Nhưng cho mình hỏi là Lisp SCT chỉ scale hình tròn theo tâm của nó,vậy để làm tương tự với 1 hình khác như hình mũi tên thì làm thế nào..Bản vẽ của mình có rất nhiều mũi tên nhưng các mũi tên lại hơi to,giờ mình muốn tất cả các mũi tên đều nhỏ đi thì làm thế nào..Bạn nào giúp mình với.. Thanks !
<<
|
Filename: 193872_chon.lsp
|
|
Tác giả: Tue_NV
Bài viết gốc: 440648
Tên lệnh: nb |
(NHỜ VIẾT LISP)
Bạn dùng thử lisp NB
Command: NB
Pick hinh chu nhat (pick vao canh) : -> Pick vào cạnh chữ nhật (chính là cạnh nan cần chia)
Pick doan thang :
Kieu chia: :+1
Nhap so nan :10
(defun c:nb()
(setq e1 (entsel "\nPick hinh chu nhat (pick vao canh) :"))
(setq e2 (car (entsel "\nPick doan thang :")))
(initget "+1 -1")
(setq kieuchia (getkword "Kieu chia: :"))
...
>>
Bạn dùng thử lisp NB
Command: NB
Pick hinh chu nhat (pick vao canh) : -> Pick vào cạnh chữ nhật (chính là cạnh nan cần chia)
Pick doan thang :
Kieu chia: :+1
Nhap so nan :10
(defun c:nb()
(setq e1 (entsel "\nPick hinh chu nhat (pick vao canh) :"))
(setq e2 (car (entsel "\nPick doan thang :")))
(initget "+1 -1")
(setq kieuchia (getkword "Kieu chia: :"))
(setq nan (getint "\n Nhap so nan :"))
(setq p1 (vlax-curve-getStartPoint e2)) (setq p2 (vlax-curve-getEndPoint e2))
(setq d2 (distance p1 p2))
(setq ptg (cadr e1)) (setq e (car e1))
(setq p11 (vlax-curve-getPointAtParam e (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointto e ptg)))))
(setq p12 (vlax-curve-getPointAtParam e (1+ (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointto e ptg))))))
(setq d1 (distance p11 p12)) (if (< (cadr p11) (cadr p12)) (setq pb p11) (setq pb p12))
(if (= kieuchia "+1") (setq khe (/ (- d2 (* nan d1)) (1- nan))) (setq khe (/ (- d2 (* nan d1)) (1+ nan))))
(if (= kieuchia "-1") (setq p1 (polar p1 (angle p1 p2) khe)))
(Repeat nan
(command "._copy" e "" "_non" pb "_non" p1)
(setq p1 (polar p1 (angle p1 p2) (+ d1 khe)))
)
)
<<
|
Tác giả: Tue_NV
Bài viết gốc: 440693
Tên lệnh: nb |
(NHỜ VIẾT LISP)
@zutum:
Lisp sửa lại đây bạn. Nếu đoạn thẳng và hình chữ nhật xiên cùng 1 góc thì Lisp chấp nhận luôn đó nhé
(defun c:nb()
(setq e1 (entsel "\nPick hinh chu nhat (pick vao canh) :"))
(setq e2 (car (entsel "\nPick doan thang :")))
(initget "+1 -1")
(setq kieuchia (getkword "Kieu chia: :"))
(setq nan (getint "\n Nhap so nan :"))
(setq p1 (vlax-curve-getStartPoint e2)) (setq p2...
>>
@zutum:
Lisp sửa lại đây bạn. Nếu đoạn thẳng và hình chữ nhật xiên cùng 1 góc thì Lisp chấp nhận luôn đó nhé
(defun c:nb()
(setq e1 (entsel "\nPick hinh chu nhat (pick vao canh) :"))
(setq e2 (car (entsel "\nPick doan thang :")))
(initget "+1 -1")
(setq kieuchia (getkword "Kieu chia: :"))
(setq nan (getint "\n Nhap so nan :"))
(setq p1 (vlax-curve-getStartPoint e2)) (setq p2 (vlax-curve-getEndPoint e2))
(if (> (cadr p1)(cadr p2)) (setq pptg p2 p2 p1 p1 pptg))
(setq d2 (distance p1 p2))
(setq ptg (cadr e1)) (setq e (car e1))
(setq p11 (vlax-curve-getPointAtParam e (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointto e ptg)))))
(setq p12 (vlax-curve-getPointAtParam e (1+ (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointto e ptg))))))
(setq d1 (distance p11 p12)) (if (< (cadr p11) (cadr p12)) (setq pb p11) (setq pb p12))
(if (= kieuchia "+1") (setq khe (/ (- d2 (* nan d1)) (1- nan))) (setq khe (/ (- d2 (* nan d1)) (1+ nan))))
(if (= kieuchia "-1") (setq p1 (polar p1 (angle p1 p2) khe)))
(Repeat nan
(command "._copy" e "" "_non" pb "_non" p1)
(setq p1 (polar p1 (angle p1 p2) (+ d1 khe)))
)
)
<<
|
Tác giả: phamthanhbinh
Bài viết gốc: 112728
Tên lệnh: loc |
Viết lisp theo yêu cầu [phần 2]
Của bạn đây
;; free lisp from cadviet.com
(defun c:loc ()
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss (ssget '((0 ....
>>
Của bạn đây
;; free lisp from cadviet.com
(defun c:loc ()
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss (ssget '((0 . "text")))
k 0
td (ssadd)
)
(while ((setq name (ssname ss k)
ent1 (entget name)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
nd (cdr (assoc 1 ent1))
j 0)
(setq ent1 (entmod (subst (cons 41 0.8) (assoc 41 ent1) ent1)))
(if (eq nd "-0.00")
(setq ent1 (entmod (subst (cons 1 "0.00") (assoc 1 ent1) ent1)))
)
(if (and (eq nd "0.00") (eq goc (/ pi 2)))
(command "erase" (ssname ss i) "")
)
(if (and (eq goc (/ pi 2)) (/= nd "0.00"))
(setq td (ssadd (cdr (assoc -1 ent1)) td))
)
(setq k (1+ k))
)
(giantext td)
(setvar "osmode" oldos)
(command "undo" "e")
)
(defun giantext ( td /)
(repeat (sslength td)
(setq i 0)
(while ((setq name1 (ssname td i)
ent1 (entget name1)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
j 0)
(while (and ((setq name2 (ssname td j)
ent2 (entget name2)
p2 (cdr (assoc 10 ent2))
di (distance p1 p2)
caochu (cdr (assoc 40 ent2))
)
(if ((progn
(if ((progn
(setq tam (polar p1 0 (/ di 2))
pt1 (polar tam pi (/ caochu 2))
pt2 (polar tam 0 (/ caochu 2))
)
(command "move" name1 "" p1 pt1)
(command "move" name2 "" p2 pt2)
)
)
(if (> (car p1) (car p2))
(progn
(setq tam (polar p2 0 (/ di 2))
pt1 (polar tam 0 (/ caochu 2))
pt2 (polar tam pi (/ caochu 2))
)
(command "move" name1 "" p1 pt1)
(command "move" name2 "" p2 pt2)
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
)
)
Chào bác Phamngoctukts,
Mình đã test lisp của bác với bản vẽ do bạn W1ndream cung cấp thì thấy chưa được như ý bác ạ.
Sau khi đọc lại code của bác thì thấy cái nguyên tắc giãn text của bác khá đơn giản. Như vậy chỉ giãn được trong trường hợp hai text trùng nhau mà thôi, Nếu có một búi text trùng nhau thì khi giãn kiểu này lại sinh ra một sự trùng khác bác ạ.
Cám ơn bác về khúc code thay width factor vì mình chả nhớ cái mã nào nó thể hiện điều này nên chưa làm trong đoạn lisp của mình. Mình sẽ bổ sung ngay bác ạ.
Chúc bác khỏe và vui.
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440775
Tên lệnh: te |
Nhờ các anh viết giúp lisp
54 phút trước, divine kai đã nói:
do dữ liệu chỉ cho 1.95m nên...
>>
54 phút trước, divine kai đã nói:
do dữ liệu chỉ cho 1.95m nên em gọt bớt file lại
du lieu 2.dwg
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
(vl-load-com)
(setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
(setvar 'cmdecho 0)
(setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
(setq i 0)
(mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (progn (setq i (1+ i)) (command "-LAYER" "M" x "C" (itoa i) "" ""))) ) lstl)
(foreach ent ss
(setq lst (list))
(setq str (cdr (assoc 1 (entget ent))))
(while (vl-string-search "\\P" str)
(setq stri (substr str 1 (vl-string-search "\\P" str)))
(if (/= stri "")
(setq lst (append lst (list stri))) )
(setq str (substr str (+ (vl-string-search "\\P" str) 3)))
)
(if (/= str "") (setq lst (append lst (list str))))
(if (= (length lst) 5 ) (progn
(setq pt (cdr (assoc 10 (entget ent))))
(mapcar '(lambda (str lay) (maketext pt str (cdr (assoc 40 (entget ent))) lay (cdr (assoc 7 (Entget ent)))
(vla-get-linespacingfactor (vlax-ename->vla-object ent)) )
(setq pt (polar pt (* 1.5 pi) (vla-get-linespacingdistance (vlax-ename->vla-object ent) )) ) ) lst lstl)
(entdel ent)
)
)
)
(setvar 'cmdecho 1)
(princ)
)
(defun maketext (point noidungtext heighttext lay style sps / oldla)
(entmakex (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText")
(cons 10 point)
(cons 40 heighttext)
(cons 1 noidungtext)
(cons 8 lay)
(cons 7 style)
(cons 44 sps)
(cons 71 2)
(cons 72 1)
(cons 73 2)
))
)
Đã sửa cho bạn đây, nhanh đáng kể
<<
|
Tác giả: nh0kdkny
Bài viết gốc: 440785
Tên lệnh: test1 |
Nhờ chỉnh sửa lisp boudary nhiều hình
còn 1 lisp này của bác DuongTrungHuy em mới test qua thấy có vẻ ổn nhưng nó bị mấy cái như hiện blipmode ( dấu cộng), chưa trả lại biến hệ thống (các cài đặt bắt điểm bị mất, size pickbox bị về mặc định, ai test thử và xử lý giúp em mấy vấn đề còn tồn tại để lisp đc ổn định hơn với
(defun giaoHuy(ob1 ob2)
(setq...
>>
còn 1 lisp này của bác DuongTrungHuy em mới test qua thấy có vẻ ổn nhưng nó bị mấy cái như hiện blipmode ( dấu cộng), chưa trả lại biến hệ thống (các cài đặt bắt điểm bị mất, size pickbox bị về mặc định, ai test thử và xử lý giúp em mấy vấn đề còn tồn tại để lisp đc ổn định hơn với
(defun giaoHuy(ob1 ob2)
(setq ob1 (vlax-ename->vla-object ob1)
ob2 (vlax-ename->vla-object ob2)
inter_lst '()
)
(if (not (vl-catch-all-error-p (setq iplist (vl-catch-all-apply 'vlax-safearray->list
(list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
)
)
)
)
(progn
(while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
iplist (cdddr iplist)
)
)
(reverse inter_lst)
)
)
)
(Defun Mid0(ddA ddB)
(setq diemgiua (list (* 0.5 (+ (car dda)(car ddb))) (* 0.5 (+ (cadr dda)(cadr ddb)))))
)
(defun cBomien(dskq)
(setvar "Delobj" 1)(setvar "Pickbox" 0)
(setq dskq1 '() dstam '())
(Foreach pt dskq
(command "region" pt "")
(setq dskq1 (append dskq1 (list (entlast)))
ob (vlax-ename->vla-object (entlast))
tamO (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
dstam (append dstam (list tamO))
)
)
(setq dskq dskq1 nmien (length dskq) i 0 ptdau (car dskq) dsbo '())
(setq dskqclai (cdr dskq))
(While dskqclai
(If (or (null dsbo)(null (member (1+ i) dsbo)))
(progn
(setq tamO (nth i dstam)
i1 0
)
(Prompt (strcat "\r" (itoa (- nmien i)) " "))
(Foreach pt dskqclai
(setq tam (nth (+ i i1 1) dstam)
i1 (1+ i1)
)
(If (< (distance tam tamO) 0.00001)
(Progn
(If (or (not (member (+ i i1 1) dsbo))(null dsbo))(setq dsbo (append dsbo (list (+ i i1 1)))))
)
)
)
)
)
(setq ptdau (car dskqclai) dskqclai (cdr dskqclai) i (1+ i))
)
(setq i 0)
(Repeat nmien
(If (member (1+ i) dsbo)(entdel (nth i dskq)))
(setq i (1+ i))
)
(setvar "Delobj" 0)(setvar "Pickbox" 4)
)
(defun c:test1 (/ ss111)
(vl-load-com)
(setvar "Osmode" 0) (setvar "Cmdecho" 0) (Setvar "orthomode" 0)
(Setvar "Blipmode" 1)
(setq ss (ssget (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))
(if ss
(Progn
(setq dsdiem_0 '() dy 1000000.0)
(foreach pt (getSS_Inter ss)
(entmake (list (cons '0 "POINT")(cons '10 pt)))
(If (and (< 0 (length dsdiem_0))(> dy (abs (- (cadr (last dsdiem_0)) (cadr pt)))))
(setq dy (abs (- (cadr (last dsdiem_0)) (cadr pt))))
)
(setq dsdiem_0 (append dsdiem_0 (list pt)))
)
(setq dsdiem_1 (vl-sort dsdiem_0 '(lambda (x y)(< (cadr x)(cadr y))))
dsdiem_2 (vl-sort-i dsdiem_0 '(lambda (x y)(< (cadr x)(cadr y))))
dsdy (list (lambda (x y)(- (cadr x)(cadr y))))
dsdy '()
ndiem (length dsdiem_1)
ymin (cadr (car dsdiem_1))
ymax (cadr (last dsdiem_1))
)
(setq dy (/ dy 2.0)
i 0 i1 0
dskq '()
dsdy (list (- (cadr (nth 1 dsdiem_1)) (cadr (nth 0 dsdiem_1))))
y0 (- ymin (car dsdy))
nlan (1- ndiem)
)
(Repeat (1- nlan)
(setq dy1 (- (cadr (nth (1+ i1) dsdiem_1)) (cadr (nth i1 dsdiem_1)))
i1 (1+ i1)
dy2 (- (cadr (nth (1+ i1) dsdiem_1)) (cadr (nth i1 dsdiem_1)))
dsdy (append dsdy (list (/ (+ dy1 dy2) 2.0)))
)
)
(command "Undo" "be")
(Repeat nlan
(setq y0 (+ y0 (nth i dsdy)))
(entmake (list (cons '0 "LINE")(cons '10 (list -10000000.0 y0))(cons '11 (list 10000000.0 y0))))
(setq e2 (entlast) ii 0 dsgiao_0 '()
i1 0 i (1+ i)
)
(Repeat (sslength ss)
(setq e1 (ssname ss ii) ii (1+ ii))
(GiaoHuy e1 e2)
(If inter_lst (setq dsgiao_0 (append dsgiao_0 inter_lst)))
)
(prompt (strcat "\r" (itoa (- nlan i)) " "))
(entdel e2)
(If dsgiao_0
(Progn
(setq dsgiao_1 (vl-sort dsgiao_0 '(lambda (x y)(< (car x)(car y))))
n2 (1- (length dsgiao_1))
)
(Repeat n2
(setq d0 (Mid0 (nth i1 dsgiao_1) (nth (1+ i1) dsgiao_1))
i1 (1+ i1)
ecu (entlast)
)
(command "-boundary" "A" "O" "P" "" d0 "")
(If (not (equal ecu (entlast)))(setq dskq (append dskq (list (entlast)))))
)
)
)
)
(command "Undo" "e")
)
)
(cBomien dskq)
(princ)
)
(defun giao(ob1 ob2 / inter_lst iplist)
(if (not (vl-catch-all-error-p (setq iplist (vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))))))
(progn
(while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
iplist (cdddr iplist)
)
)
(reverse inter_lst)
)
)
)
(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object e) lst))
)
(repeat (1- (vl-list-length lst))
(setq obj (car lst))
(foreach ob1 (setq lst (vl-remove obj lst ))
(if (setq tmp_lst (giao ob1 obj))
(foreach pt tmp_lst
(if (not (vl-position pt giao_lst)) (setq giao_lst (cons pt giao_lst)))
)
)
(print tmp_lst)
)
)
giao_lst
)
<<
|
Filename: 440785_test1.lsp
|
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440767
Tên lệnh: te |
Lấy lấy kí tự
3 giờ trước, divine kai đã nói:
3 giờ trước, divine kai đã nói:
du lieu 99.dwg
em xin phép gửi dữ liệu, ai có lòng tốt thì giúp em nha
(defun c:te (/ ss n value pos)
(if (not (tblsearch "LAYER" "TEN"))
(command "Layer" "M" "TEN" "")
)
(if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
(progn
(setq n 0)
(repeat (sslength ss)
(setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
(vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
(setq str (cdr (assoc 1 (entget (ssname ss n))))))))
)
)
)
(if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx)) (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
(cdr (assoc 50 (entget (ssname ss n)))) width))
)
) ;if
(setq n (1+ n))
) ;repeat
) ;progn
) ;if
(princ)
)
(defun make (noidung goc ent pt)
(entmake
(list
(cons 0 "TEXT")
(cons 100 "AcDbText")
(cons 10 (trans pt 1 0))
(assoc 40 (entget ent))
(cons 1 noidung)
(assoc 7 (entget ent))
(cons 50 goc)
(cons 8 "TEN")
(cons 100 "AcDbText")
)
)
)
Sửa theo bài của BEE
<<
|
Tác giả: Bee
Bài viết gốc: 440793
Tên lệnh: test |
Lấy lấy kí tự
10 giờ trước, divine kai đã nói:
bạn ơi, mình cũng gặp...
>>
10 giờ trước, divine kai đã nói:
bạn ơi, mình cũng gặp trường hợp tương tự, nhưng sao sài lisp thì không quét được nhiều đối tượng vs quét có nhiều đối tượng khác dạng line hay text khác thì lisp không chạy, bạn có thể sửa giúp mình không...( mình chỉ có thể quét rất ít đối tượng )
Có chỉnh lại theo bản vẽ của bạn, đã test thấy chạy ok với lisp sau: sau khi gõ lệnh - TEST thì gõ all xong enter chạy bình thường ^_^ Hoặc dùng lisp Doan NV filter giá trị text cho nhanh hơn.
(defun c:test (/ ss n value pos)
(if (not (tblsearch "LAYER" "@TEN"))
(command "Layer" "M" "@TEN" "")
)
(if (setq ss (ssget '((0 . "TEXT"))))
(progn
(setq n 0)
(repeat (sslength ss)
(if (> (strlen (cdr (assoc 1 (entget (ssname ss n))))) 6)
(progn
(setq value (vl-list->string
(vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
(vl-string->list
(vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
)
)
)
(if (setq pos (vl-string-search "/" value 1))
(entmake
(list
(cons 0 "TEXT")
(cons 100 "AcDbText")
(cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
(assoc 40 (entget (ssname ss n)))
(cons 1 (substr value 1 pos))
(assoc 7 (entget (ssname ss n)))
(assoc 50 (entget (ssname ss n)))
(cons 8 "@TEN")
(cons 100 "AcDbText")
)
)
) ;if
)
)
(setq n (1+ n))
) ;repeat
) ;progn
) ;if
(princ)
)
<<
|
Filename: 440793_test.lsp
|
|
Tác giả: nh0kdkny
Bài viết gốc: 440782
Tên lệnh: tddmoi |
Nhờ chỉnh sửa lisp boudary nhiều hình
Em muốn tìm lisp có thể bo đc nhiều hình và tách riêng các đường bo thành polyline
em có tìm được 1 lisp của bác phamngoctukts nhưng load vào gõ lệnh không được không biết có đúng lệnh không nhờ mọi người xem giúp. Trong lisp có phần đánh số nữa thì nhờ mọi người bỏ giúp em chỉ giữ lại phần bo các hình
;; free...
>>
Em muốn tìm lisp có thể bo đc nhiều hình và tách riêng các đường bo thành polyline
em có tìm được 1 lisp của bác phamngoctukts nhưng load vào gõ lệnh không được không biết có đúng lệnh không nhờ mọi người xem giúp. Trong lisp có phần đánh số nữa thì nhờ mọi người bỏ giúp em chỉ giữ lại phần bo các hình
;; free lisp from cadviet.com
(defun ndt();Nhom doi tuong
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget '((0 . "line,arc"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(creatbo lss)
)
(defun creatbo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name))
(if (/= (cdr (assoc 0 ent)) "ARC")
(progn
(setq p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
)
)
(if (= (cdr (assoc 0 ent)) "ARC")
(progn
(setq dgiua (midarc name)
p1 pdau
p2 pcuoi)
)
)
(setq j 0)
(while (and (< j (sslength ss)) (/= j i))
(setq name1 (ssname ss j)
ent1 (entget name1))
(if (/= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1)))
)
)
(if (= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq dgiua (midarc name1)
p3 pdau
p4 pcuoi)
)
)
(setq giao (inter name name1))
(if (and (/= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent2)) "ARC"))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (/= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(breakarc name giao)
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent)) "ARC")
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name1 giao)
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01))
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name giao)
(breakarc name1 giao)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)
(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ptt (centroid namel))
(command "point" ptt)
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(setq i (1+ i))
)
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (> (sslength ssdk) 2)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
)
(if (= (sslength (ssget "cp" dsp '((0 . "lwpolyline")))) 1)
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
(setq i (1+ i))
)
(command "erase" list_point "")
)
(defun c:tddmoi ()
(inittdd)
(command "undo" "be")
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
list_chu (ssadd)
nhomss nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq k 0)
(while (< k (length nhomss))
(setq sscon (nth k nhomss))
(setq ssmoi (sapxep sscon))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p))
(command "area" "o" name)
(setq i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0) " dien tich: " (rtos (getvar "area") 2 3))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(setq list_chu (ssadd (entlast) list_chu))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3)
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq k (1+ k))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(command "_.copyclip" list_chu "")
(command "block" "chu" "0,0" list_chu "")
(command "insert" "chu" "0,0" "" "" "")
(setq pchu (nth 0 (acet-ent-geomextents (entlast))))
(setvar "osmode" oldos)
(command "undo" "e")
(command "undo" "")
(command "_.pasteclip" pchu)
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)
(defun inittdd ()
(setq
tdd_old_er *error*
*error* tdderror
)
)
(defun tdderror (errmsg)
(loitdd)
)
(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)
(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re)
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)
(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (+ (cadr ps) (* i 0.001))) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(setq m 0)
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
(setq m (1+ m))
)
ssmoi
)
(defun inter ( t1 t2 / ob1 ob2 g kq sd)
(Vl-Load-Com)
(setq ob1 (vlax-ename->vla-object t1)
ob2 (vlax-ename->vla-object t2)
)
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
g
)
(defun breakarc ( n1 pn / )
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
ang (angle tam pn)
)
(entmod (subst (cons 50 ang) (assoc 50 entarc) entarc))
(entmakex (subst (cons 51 ang) (assoc 51 entarc) entarc))
(setq lm (entlast) ss (ssadd lm ss))
)
(defun midarc ( n1 /)
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
pgiua (polar pdau (angle pdau pcuoi) (/ (distance pdau pcuoi) 2))
)
pgiua
)
New Text.lsp <<
|
Filename: 440782_tddmoi.lsp
|
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440802
Tên lệnh: te |
Nhờ các anh viết giúp lisp
18 giờ trước, divine kai đã nói:
chủ yếu là vị trí text bị...
>>
18 giờ trước, divine kai đã nói:
chủ yếu là vị trí text bị thay đổi do dữ liệu 4-5 hàng , muốn giữ nguyên vị trí thì làm cách nào anh
Đã giải quyết vấn đề 4-5 hàng cho bạn, chọn 3 hay 4 hay 5 hàng đều được
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str pref)
(vl-load-com)
(setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
(setvar 'cmdecho 0)
(setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
(setq i 0)
(mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (progn (setq i (1+ i)) (command "-LAYER" "M" x "C" (itoa i) "" ""))) ) lstl)
(foreach ent ss
(setq lst (list))
(setq str (cdr (assoc 1 (entget ent))))
(while (vl-string-search "\\P" str)
(setq stri (substr str 1 (vl-string-search "\\P" str)))
(setq lst (append lst (list stri)))
(setq str (substr str (+ (vl-string-search "\\P" str) 3)))
)
(if (/= str "") (setq lst (append lst (list str))))
(if (or (= (length lst) 4)
(= (length lst) 5) )(progn
(setq pt (cdr (assoc 10 (entget ent))))
(setq pref (vl-string-right-trim "1234567890" (car lst)))
(mapcar '(lambda (str lay) (if (and (/= str (car lst)) (/= pref "")) (setq str (strcat pref str)))
(maketext pt str lay ent )
(setq pt (polar pt (* 1.5 pi) (vla-get-linespacingdistance (vlax-ename->vla-object ent) )) ) ) lst lstl)
(entdel ent)
)
)
)
(setvar 'cmdecho 1)
(princ)
)
(defun maketext (point noidungtext lay entg / oldla)
(vla-move (vla-copy (vlax-ename->vla-object entg)) (vlax-3d-point (cdr (assoc 10 (entget entg)))) (vlax-3d-point point))
(vla-put-textstring (vlax-ename->vla-object (entlast)) noidungtext)
(vla-put-layer (vlax-ename->vla-object (entlast)) lay)
(vla-put-color (vlax-ename->vla-object (entlast)) 256))
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440830
Tên lệnh: te |
Lấy lấy kí tự
37 phút trước, divine kai đã nói:
hiện tại em muốn lấy thêm...
>>
37 phút trước, divine kai đã nói:
hiện tại em muốn lấy thêm dữ liệu là chỉ chữ ở đầu tiên , ví dụ như T 83/243.6 thì khi quét lisp sẽ cho ra kết quả là T, anh có thể sửa giúp em trên lisp này luôn không ạ, em cảm ơn anh
30 phút trước, divine kai đã nói:
có nhiều dữ liệu bị sai khi quét lisp ví dụ như ĐM, 2L và vườn thì khi chạy nó cho ra kết quả bị sai anh có cách nào sửa không anh?
du lieu bi sai.dwg
Đã sửa
(defun c:te (/ ss n value pos)
(if (not (tblsearch "LAYER" "Code"))
(command "Layer" "M" "Code" "")
)
(if (not (tblsearch "LAYER" "Thua"))
(command "Layer" "M" "Thua" "")
)
(if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
(progn
(setq key (keyword '("Ma" "Thua") "Thua" "Ban muon lay ket qua nao"))
(setq n 0)
(repeat (sslength ss)
(setq value (substr (setq str (cdr (assoc 1 (entget (ssname ss n))))) 1 (vl-string-search "/" str)))
(setq ma (vl-string-right-trim "0123456789" value))
(setq thua (substr value (+ 1 (strlen ma) )))
(make ma 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))) "Code")
(if (= key "Thua") (progn
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx)) (car (vlax-safearray->list mn))))
(entdel (entlast))
(make thua (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
(cdr (assoc 50 (entget (ssname ss n)))) width) "Thua"))
(vla-put-rotation (vlax-ename->vla-object (entlast)) (cdr (assoc 50 (entget (ssname ss n)))) ))
; ) ;if
(setq n (1+ n))
) ;repeat
) ;progn
) ;if
(princ)
)
(defun make (noidung goc ent pt lay)
(entmake
(list
(cons 0 "TEXT")
(cons 100 "AcDbText")
(cons 10 (trans pt 1 0))
(assoc 40 (entget ent))
(cons 1 noidung)
(assoc 7 (entget ent))
(cons 50 goc)
(cons 8 lay)
(cons 100 "AcDbText")
)
)
)
(defun keyword (key default promp / str1 str2 str3 str4)
(setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
(setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
(setq str1 (substr str1 1 (1- (strlen str1))))
(setq str2 (substr str2 1 (1- (strlen str2))))
(initget str1)
(setq str3 (strcat "\n" promp " <" default "> "))
(if (not (setq str4 (getkword str3)))
default
str4
)
)
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440928
Tên lệnh: te |
Lisp nối hai điểm cuối của 2 polyline với nhau?
4 giờ trước, united đã nói:
Em xin trình bày theo các thao tác làm...
>>
4 giờ trước, united đã nói:
Em xin trình bày theo các thao tác làm thông thường trên CAD ạ:
Có 2 polyline thuộc 2 layer khác nhau (giả sử là layer1 và layer2). Vẽ 1 đường thẳng nối 2 đỉnh của 2 polyline rồi dùng lệnh Join nối đường thẳng thuộc layer1 với đường thẳng vừa vẽ.
Em xin nhờ các anh viết giúp em 1 lisp giúp đơn giản hóa các bước trên ạ.
Như hình là em có rất nhiều đường thẳng thuộc layer1 và layer2 nằm xen kẽ nhau. Nếu chọn được một lượt cho ra kết quả (như hình bên phải) thì hay quá ạ.
Em cảm ơn ạ!
Bạn Test thử xem oke chưa
(Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
(setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE")))))
(command "UNDO" "BE")
(setq lst (list))
(while (setq ent (car ss))
(Setq ss (cdr ss))
(setq lay (cdr (assoc 8 (entget ent))))
(setq lst1 (list ent))
(foreach ent2 ss
(if (= (cdr (assoc 8 (entget ent2))) lay) (progn(setq lst1 (append lst1 (list ent2)))(setq ss (vl-remove ent2 ss))
)))
(setq lst (append lst (list lst1)))
)
(if (= (length lst) 2) (progn
(setq lst (mapcar '(lambda (z) (setq z (vl-sort z '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))) lst))
(if (> (caddr (assoc 10 (entget (caar lst)))) (caddr (assoc 10 (entget (caadr lst)))))
(progn (setq ss1 (car lst)) (setq ss2 (cadr lst)))(progn (setq ss2 (car lst)) (setq ss1 (cadr lst))))
(setq pt (getpoint "\nPick phia noi"))
(mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
lst2 (acet-geom-vertex-list y))
(setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
(if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
(if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
(acet-lwpline-make (list (list pt1 pt2)))
(command "pedit" "m" x (entlast) "" "join" "0.00" "")
) ss1
ss2
)
))
(command "UNDO" "E")
)
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440935
Tên lệnh: te |
Lisp nối hai điểm cuối của 2 polyline với nhau?
1 giờ trước, united đã nói:
Có 1 vấn đề anh ạ. Là khi em xoay...
>>
1 giờ trước, united đã nói:
Có 1 vấn đề anh ạ. Là khi em xoay các pline theo các góc khác nhau. Sẽ có lúc đoạn nối bị sai anh ạ. Đáng lẽ đoạn nối phải join với đường màu đỏ thì nó lại join với đường màu xanh.
Em có up lại file với một số trường hợp cho kết quả không như ý muốn ạ.
Mong anh giúp đỡ!
Ex2.dwg
Đây nhé:
(Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
(setq ent1 (car (entsel "\nPick Layer 1"))
ent2 (car (entsel "\nPick Layer 2")))
(setq lay1 (cdr (assoc 8 (entget ent1)))
lay2 (cdr (assoc 8 (entget ent2))))
(setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 (strcat lay1 "," lay2))))))
(command "UNDO" "BE")
(setq ss1 (list) ss2 (list))
(mapcar '(lambda (x) (if (= (cdr (Assoc 8 (entget x))) lay1 ) (setq ss1 (append ss1 (list x))) (setq ss2 (append ss2 (list x))))) ss)
(setq ss1 (vl-sort ss1 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
(setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
(setq pt (getpoint "\nPick phia noi"))
(mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
lst2 (acet-geom-vertex-list y))
(setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
(if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
(if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
(acet-lwpline-make (list (list pt1 pt2)))
(command "pedit" "m" x (entlast) "" "join" "0.00" "")
) ss1
ss2
)
(command "UNDO" "E")
)
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440951
Tên lệnh: te |
Lisp nối hai điểm cuối của 2 polyline với nhau?
5 phút trước, united đã nói:
Có lẽ em hơi tham, nhưng anh có thể...
>>
5 phút trước, united đã nói:
Có lẽ em hơi tham, nhưng anh có thể bỏ bước chọn Layer 1 và Layer 2 được không ạ? Và mặc định "Layer 1" và "Layer 2" là layer có sẵn trong bản vẽ (ví dụ: Layer1 và Layer2). Vì trong bản vẽ của em luôn có sẵn "layer1" và "layer2" rồi. Và đường nối luôn thuộc "layer1".
Em cảm ơn anh lần nữa!
Chưa chắc các bản vẽ của bạn đã có sẵn các layer đó, vì bản test này tên layer khác nhau.
Sửa lại cho bạn mỗi lần mở bv sẽ pick chọn 1 lần, các lần sau k phải pick lại, nếu muốn pick lại thì enter 2 lần
(Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
(if (not lay1) (progn
(setq ent1 (car (entsel "\nPick Layer 1"))
ent2 (car (entsel "\nPick Layer 2")))
(setq lay1 (cdr (assoc 8 (entget ent1)))
lay2 (cdr (assoc 8 (entget ent2)))) ))
(if (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 (strcat lay1 "," lay2)))))) (progn
(command "UNDO" "BE")
(setq ss1 (list) ss2 (list))
(mapcar '(lambda (x) (if (= (cdr (Assoc 8 (entget x))) lay1 ) (setq ss1 (append ss1 (list x))) (setq ss2 (append ss2 (list x))))) ss)
(setq ss1 (vl-sort ss1 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
(setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
(setq pt (getpoint "\nPick phia noi"))
(mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
lst2 (acet-geom-vertex-list y))
(setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
(if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
(if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
(acet-lwpline-make (list (list pt1 pt2)))
(command "pedit" "m" x (entlast) "" "join" "0.00" "")
) ss1
ss2
)
(command "UNDO" "E")
) (progn (setq lay1 nil) (c:te)))
)
<<
|