| Info | File |
Tác giả: Tue_NV
Bài viết gốc: 60808
Tên lệnh: atc |
Kéo cung tròn thành đường tròn?
Chào Tue_NV Xin phép bổ sung phần Properties (thuộc tính : layer, color, linetype, lineweight)
dùng Entdel thay cho Command Erase.
(defun c:AtC(/ ar ent ds...
>>
Chào Tue_NV Xin phép bổ sung phần Properties (thuộc tính : layer, color, linetype, lineweight)
dùng Entdel thay cho Command Erase.
(defun c:AtC(/ ar ent ds val); Arc to Circle
(defun dxf(id ent) (cdr (assoc id ent)) )
(setq ar (car(entsel "\n Chon arc :")))
(setq ent (entget ar)
ds (list (cons 0 "CIRCLE") (cons 10 (dxf 10 ent)) (cons 40 (dxf 40 ent)) ))
(setq ds (append ds (list (cons 8 (dxf 8 ent)))) );layer
(if (setq val (dxf 62 ent));color
(setq ds (append ds (list (cons 62 val))) )
)
(if (setq val (dxf 6 ent));line type
(setq ds (append ds (list (cons 6 val))) )
)
(if (setq val (dxf 370 ent));line weight
(setq ds (append ds (list (cons 370 val))) )
)
(entmake ds)
(entdel ar)
(princ)
)
Chào anh gia bách
Lời đầu tiên Tue_NV xin cảm ơn anh gia bách rất nhiều vì sự chia sẻ
Nếu để gán thuộc tính của arc cho circle thì mình vẫn có thể sử dụng lệnh MA được mà
(defun c:ACi(/ ar ent)
(setq ar (car(entsel "\n Chon arc :")))
(setq ent (entget ar))
(entmake (list (cons 0 "CIRCLE") (cons 10 (cdr(assoc 10 ent))) (cons 40 (cdr(assoc 40 ent)))))
(command "MATCHPROP" ar (entlast) "")
(entdel ar)
(princ)
)
<<
|
Tác giả: ketxu
Bài viết gốc: 456773
Tên lệnh: on off |
Lisp điều khiển Plot Transpareny trong hộp thoại Plot
Quick Google và 1cent code để bạn dùng ^^
(defun LayoutTransparency (layout ON / xType xData )
(setq xData (vlax-make-safearray vlax-vbVariant '(0 . 1)))
(setq xType (vlax-make-safearray vlax-vbInteger '(0 . 1)))
(vlax-safearray-fill xData (list(vlax-make-variant "PLOTTRANSPARENCY")(vlax-make-variant ON)))
(vlax-safearray-fill xType (list 1001...
>>
Quick Google và 1cent code để bạn dùng ^^
(defun LayoutTransparency (layout ON / xType xData )
(setq xData (vlax-make-safearray vlax-vbVariant '(0 . 1)))
(setq xType (vlax-make-safearray vlax-vbInteger '(0 . 1)))
(vlax-safearray-fill xData (list(vlax-make-variant "PLOTTRANSPARENCY")(vlax-make-variant ON)))
(vlax-safearray-fill xType (list 1001 1071))
(vla-setXdata layout xType xData)
(entmod(entget (vlax-vla-object->ename layout) '("*")))
(princ (strcat "Plot Transparency now is " (if (zerop ON) "OFF" "ON") "!"))
(princ)
)
(defun c:ON()
(LayoutTransparency (vla-get-activelayout (vla-get-activedocument(vlax-get-acad-object))) 1) ; 1=ON 0=off
)
(defun c:OFF()
(LayoutTransparency (vla-get-activelayout (vla-get-activedocument(vlax-get-acad-object))) 0) ; 1=ON 0=off
)
<<
|
|
Filename: 456773_on_off.lsp
|
|
Tác giả: hhhhgggg
Bài viết gốc: 64497
Tên lệnh: vplk |
Lisp vẽ Pline vét bùn ????
Chào Zuy782006Bạn dùng thử LISP này, điểm hạn chế là chỉ vẽ đuợc đuờng thẳng.
(defun c:VPLK( )
(command "undo" "be")
(command...
>>
Chào Zuy782006Bạn dùng thử LISP này, điểm hạn chế là chỉ vẽ đuợc đuờng thẳng.
(defun c:VPLK( )
(command "undo" "be")
(command "_pline" (getpoint "\n First point :"))
(while (>= (getvar "cmdactive") 1)
(princ "\n Next point :")
(command PAUSE)
)
(command "pedit" "m" "L" (entlast) "" "c" "")
(command "undo" "end")
(princ)
)
Các bác Pro à ? Ko bit các bác viết Lisp xong các bác có chạy thử ko ? Em rất cảm ơn các bác vì đã nhiệt tình quan tâm giúp đỡ.Nhưng mà Lisp các bác viết ra thì ko cái nào chạy được cả, của bác Tuệ và Giá bạch đều ko chạy đúng. Nếu các bác đã từng dùng nova thi bit nó vét bùn thế nào, nhưng em biết là viết được như thế thì sẽ tốn công nên đưa ra yêu cầu rất nhỏ.
Đề bài : Có 1 Pline có từ trước, Lisp sẽ vẽ ra 1 Pline dạng copy xuống bên dưới 1 đoạn b và chú ý là nó vẽ thêm cả 2 mẩu đoạn thẳng ở 2 đầu của Pline vẽ thêm để nối liền 2 Pline thành 1 hình kín phục vụ cho việc tính khối lượng ???
điểm đầu và điểm cuối vẽ Pline là 2 điểm bất kỳ trên Pline ban đầu !
Các bác chỉnh lại CODE và test giúp em nhé ! Cảm ơn các bác !!!
<<
|
Tác giả: study_forever
Bài viết gốc: 74789
Tên lệnh: dt |
Lisp move text vào tâm hình chữ nhật
Chào study_foreverTiếng Việt mình, cụm từ "Đã thế" đuợc dùng trong bối cảnh nào vậy ta ?
Hàm (defun mid (ent / p1 p2) ..) bạn...
>>
Chào study_foreverTiếng Việt mình, cụm từ "Đã thế" đuợc dùng trong bối cảnh nào vậy ta ?
Hàm (defun mid (ent / p1 p2) ..) bạn post lên không trả về tâm của 1 đối tuợng đâu !
Thưc chất là nó trả về tâm của hình chử nhật bao quanh đối tuợng đó.
"Đã thế" : tâm của 1 cung tròn (ARC) ở đâu ?
"Đã thế" : tâm của 1 đuờng kích thuớc (Dimension) ở đâu ?
.....
Khái niệm "tâm 1 vật nào đó" mà bạn Post ở trên cần phải hiểu là tâm của hình chử nhật bao quanh đối tuợng đó.
"Đã thế" :bạn chạy thử LISP này xem có Đã đã đã ............. hôn ?
(defun c:dt (/ cen des obj src ss_ent typ)
(vl-load-com)
(defun mid (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2))
(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5))
)
(and
(princ "\nChon doi tuong can di chuyen (Text,MText) : ")
(setq ss_ent (ssget "_:S:E" '((0 . "*TEXT"))) )
(setq src (ssname ss_ent 0))
(not(redraw src 3))
(setq obj (vlax-ename->vla-object src)
typ (vlax-get obj 'ObjectName))
(setq des (car (entsel "\nDoi tuong dich: ")))
(not(redraw src 4))
(setq cen (vlax-3d-point(mid des)))
(cond
((= typ "AcDbText")
(vla-put-alignment obj 10)
(vla-put-TextAlignmentPoint obj cen)
)
((= typ "AcDbMText")
(vla-put-AttachmentPoint obj 5)
(vla-put-InsertionPoint obj cen)
)
)
)
(princ)
)
Ơ nhưng mà bác Gia_bach ơi, sao cái lisp dt bác lại bỏ chức năng move các đối tượng mà chỉ để chức năng đối tượng là text thôi à? Thế thì mất hết ý nghĩa của cái lisp này rồi, em muốn vẫn giữ nguyên chức năng move các đối tượng khác vào tâm 1 đối tượng nào đó và bổ sung thêm đối tượng là mtext thôi (text thì đã được rồi), bác xem lại giúp em nhé, thanks các bác nhiều nhiều
<<
|
Tác giả: leejang
Bài viết gốc: 143731
Tên lệnh: dc |
lisp đổi màu tất cả các đường DIM ?
Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)
(defun C:dc()
(vl-load-com)
(setq...
>>
Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)
(defun C:dc()
(vl-load-com)
(setq txtcol 2 lcol 30)
(setq colorObj (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17"))
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "DIMENSION,LEADER")))))))
(if (vlax-property-available-p ent 'TextColor)
(vla-put-Textcolor ent txtcol)
)
(if (vlax-property-available-p ent 'DimensionLinecolor)
(vla-put-DimensionLinecolor ent lcol)
)
(if (vlax-property-available-p ent 'ExtensionLinecolor)
(vla-put-ExtensionLinecolor ent lcol)
)
)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "MULTILEADER")))))))
(vla-put-ColorIndex colorObj ldrcol)
(vla-put-LeaderLineColor ent colorObj)
(vla-put-ColorIndex colorObj txtcol)
(vla-put-TrueColor ent colorObj)
)
)
Bác xem lại giúp em cái. E tải về chạy thì được báo lỗi sau :
Command: dc
error: Automation Error. Problem in loading application
<<
|
Tác giả: Hoangvulandscape
Bài viết gốc: 220843
Tên lệnh: ha |
Nhờ viết lisp canh chỉnh block trong bảng thống kê
Lisp Move Block vào tâm Rectangle và Scale để Block nằm gọn trong Rectangle.
(defun C:HA( / ent1 ent2 pt ll ur pt1 pt2...
>>
Lisp Move Block vào tâm Rectangle và Scale để Block nằm gọn trong Rectangle.
(defun C:HA( / ent1 ent2 pt ll ur pt1 pt2 d1 d2 sc)
;Doan Van Ha - CADViet.com - Ngay 22/11/2012
;Chuc nang: Move Block vao tam Rectangle va Scale Block cho nam gon trong Rectangle.
(command "undo" "be") (vl-load-com)
(setq osm (getvar "osmode") cmd (getvar "cmdecho") dmz (getvar "dimzin"))
(mapcar 'setvar '("osmode" "cmdecho" "dimzin") '(0 0 0))
(while
(and
(setq ent1 (car (entsel "\nChon Block: ")))
(setq ent2 (car (entsel "\nChon Boundary: "))))
(TAM_ENT ent1)
(setq pt1 pt d1 (- (cadr ur) (cadr ll)))
(TAM_ENT ent2)
(setq pt2 pt d2 (- (cadr ur) (cadr ll)))
(initget 6)
(setq sc (getreal (strcat "\nNhap ti le Scale <" (rtos (/ d2 d1) 2 2) ">: ")))
(if (not sc) (setq sc (/ d2 d1)))
(command "move" ent1 "" pt1 pt2)
(command "scale" ent1 "" pt1 sc))
(mapcar 'setvar '("osmode" "cmdecho" "dimzin") (list osm cmd dmz))
(command "undo" "end")
(princ))
;----- Hµm lÊy t©m (vµ 2 gãc ll ur) cña 1 ent bÊt kú.
(defun TAM_ENT (ent)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(setq ll (vlax-safearray->list ll) ur (vlax-safearray->list ur) pt (mapcar '* (mapcar '+ ll ur) '(0.5 0.5 0.5))))
Thanks bạn Hà nhé! Lisp chạy rất tốt!
<<
|
Tác giả: thiep
Bài viết gốc: 457047
Tên lệnh: gid |
SẮP XẾP CÁC POINTS THÀNH ĐƯỜNG THẲNG
Lisp có sẵn chỉ chỉnh lại 1 chút. Lisp gửi đến bạn, lệnh là GID
(defun c:gid (/ ss acadobj doc ent_lst ss po_og Y_og po_10 po_n eng)
(defun *error* (msg)
(and doc (_EndUndo doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(defun _StartUndo (doc) (vla-StartUndoMark doc))
...
>>
Lisp có sẵn chỉ chỉnh lại 1 chút. Lisp gửi đến bạn, lệnh là GID
(defun c:gid (/ ss acadobj doc ent_lst ss po_og Y_og po_10 po_n eng)
(defun *error* (msg)
(and doc (_EndUndo doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(defun _StartUndo (doc) (vla-StartUndoMark doc))
(defun _EndUndo (doc)
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndomark doc)
)
)
(setq acadobj (vlax-get-acad-object)
doc (vla-get-ActiveDocument acadobj)
)
(_StartUndo doc)
(acet-sysvar-set (list "cmdecho" 0 "osmode" 0))
(command "_ucs" "w")
(setq ss (ssget '((0 . "POINT"))))
(if (null ss)
(progn (princ "\nNo objects selected.") (exit))
)
(setq ent_lst (acet-ss-to-list ss))
(setq po_og (getpoint "\nPick 1 \U+0111i\U+1EC3m \U+0111\U+1EC3 l\U+1EA5y tung \U+0111\U+1ED9 Y:"))
(setq Y_og (caDr po_og))
(foreach x ent_lst
(setq eng (entget x)
po_10 (acet-dxf 10 eng)
po_n (list (car po_10) Y_og (caddr po_10))
)
(entmod (subst (cons 10 po_n) (assoc 10 eng) eng))
(entupd x)
)
(ACET-SYSVAR-RESTORE)
(command "_ucs" "P")
(_EndUndo doc)
(princ)
(princ "\nOk")
)
<< |
Tác giả: tranlaogia
Bài viết gốc: 79587
Tên lệnh: vex |
Thêm node vào đường Pline
Chào bác laogia, lisp này khắc phục lisp them_dinh_pline_2.vlx của bác Nataca sẽ không kén vị trí điểm cần insert: ngoài pline (vị trí góc tù), trên... >>
Chào bác laogia, lisp này khắc phục lisp them_dinh_pline_2.vlx của bác Nataca sẽ không kén vị trí điểm cần insert: ngoài pline (vị trí góc tù), trên pline, thêm node đầu pline, cuối pline.
;;; lisp them dinh vao LWP
;;; copyright by Thiep V.2: 7/2009
;;;---------------
(defun arrpoint (po / PntArr)
(setq PntArr (vlax-make-safearray
vlax-vbDouble
(cons 0 1)
)
)
(vlax-safearray-fill PntArr po)
)
(defun LWP (Lpoint *ModelSpace* / PntArr)
(setq PntArr (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length Lpoint)))
)
)
(vlax-safearray-fill PntArr Lpoint)
(vla-AddLightWeightPolyline *ModelSpace* PntArr)
)
(defun rever (en *Model* / obj n Lx Ly Lcor)
(setq obj (vlax-ename->vla-object en))
(setq Lcor (vlax-safearray->list
(vlax-variant-value
(vlax-get-property obj 'Coordinates)
)
)
)
(setq n 0
Lx nil
Ly nil
)
(foreach cor Lcor
(if (= 0 (rem n 2))
(setq Lx (append Lx (list cor)))
(setq Ly (append Ly (list cor)))
)
(setq n (1+ n))
)
(setq Lx (Reverse Lx)
Ly (Reverse Ly)
n 0
Lcor nil
)
(repeat (length Lx)
(setq Lcor (append Lcor (list (nth n Lx) (nth n Ly)))
n (1+ n)
)
)
(vla-delete obj)
(LWP Lcor *Model*)
)
;;;-----------------------------------
(defun c:vex (/ ActDoc *Model* wp wpObj n pmid pcl Pe)
(setvar "osmode" 0)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setq wp (car (entsel "\nPick a LWPOLYLINE ")))
(redraw wp 3)
(while (setq pmid (getpoint "\nPick a point for insert "))
(setq wpObj (vlax-ename->vla-object wp))
(setq pcl (vlax-curve-getClosestPointTo wp pmid)
n (fix (vlax-curve-getParamAtPoint wp pcl))
bul (vla-getbulge wpObj n)
)
(if (= n 0)
(progn
(rever wp *Model*)
(setq wp (entlast))
(setq Pe (vlax-curve-getEndPoint wp)
n (vlax-curve-getParamAtPoint wp Pe))
)
)
(setq pmid (list (car pmid)
(cadr pmid)
)
)
(vla-AddVertex wpObj (1+ n) (arrpoint pmid))
(if (/= bul 0) (vla-setBulge wpObj (+ n 1) bul))
(vla-update wpObj)
)
(princ "\nChuc cac ban vui ve! Thiep")
(princ)
)
bác Thiệp thử kiểm tra lại lisp này xem, em thử rùi nhưng vẫn không thêm được điểm trên đường pline. cám ơn bác
<<
|
Tác giả: thiep
Bài viết gốc: 457275
Tên lệnh: al9 |
Nhờ tạo lisp tự động vẽ pline theo điểm, block, text có sẵn
Lisp của bạn đây, lệnh là AL9
;;; Lisp add lwpolyline promt insertpoint of texts blocks === by Trân Thiêp 05/2020
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun TD:Text (ent / X11)
(setq Ma10 (dxf 10 ent))
(setq Ma11 (dxf 11 ent))
(setq X11 (car Ma11))
(setq Ma71 (dxf 71 ent))
(setq Ma72 (dxf 72 ent))
(if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
...
>>
Lisp của bạn đây, lệnh là AL9
;;; Lisp add lwpolyline promt insertpoint of texts blocks === by Trân Thiêp 05/2020
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun TD:Text (ent / X11)
(setq Ma10 (dxf 10 ent))
(setq Ma11 (dxf 11 ent))
(setq X11 (car Ma11))
(setq Ma71 (dxf 71 ent))
(setq Ma72 (dxf 72 ent))
(if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
(and (= Ma71 0) (= Ma72 3))
(and (= Ma71 0) (= Ma72 5))
)
Ma10
Ma11
)
)
;;;=================================================
(defun c:al9 (/ doc ss entlst lstpo po)
(defun *error* (msg)
(and doc (_EndUndo doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(defun _EndUndo (doc)
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndomark doc)
)
)
(acet-sysvar-set '("cmdecho" 0 "osmode" 0))
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark doc)
(command "_ucs" "w")
(prompt
"\nCh\U+1ECDn t\U+1EADp h\U+1EE3p các text, block b\U+1EB1ng ph\U+01B0\U+01A1ng th\U+1EE9c FENC:"
)
(setq lstpo nil)
(if (setq ss (ssget "F" (ACET-UI-FENCE-SELECT) '((0 . "TEXT,INSERT"))))
(progn (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach ent entlst
(cond ((= (dxf 0 ent) "TEXT") (setq po (TD:Text ent)))
((= (dxf 0 ent) "INSERT") (setq po (dxf 10 ent)))
)
(setq lstpo (cons po lstpo))
)
(acet-lwpline-make (list lstpo))
)
(prompt "\nCh\U+01B0a ch\U+1ECDn t\U+1EADp h\U+1EE3p texts, blocks")
)
(acet-sysvar-restore)
(command "_ucs" "P")
(_EndUndo doc)
(princ "\nOk")
)
Chúc bạn vui.
<<
|
Tác giả: thiep
Bài viết gốc: 457407
Tên lệnh: ofs |
XIN GIÚP ĐỠ VỀ OFFSET POLYLINE DẠNG RECTANG
22 giờ trước, gia_bach đã nói:
Offset 500 và -500 rồi so sánh 2 pline...
>>
22 giờ trước, gia_bach đã nói:
Offset 500 và -500 rồi so sánh 2 pline mới, thằng nào có diện tích (AREA) lớn hơn thì chọn, xóa thằng kia.
Một cách khác không phải so sánh diện tích rồi xoá đỡ tốn thời gian. Lisp này lấy trên nền lisp OFS của @tranducanh18 gửi ở trên
(vl-load-com)
(defun GetA (lst)
(apply '+
(mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
lst
(cons (last lst) lst)
)
)
)
(defun c:ofs (/ ss lay lst obj bit #d #dold)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark ActDoc)
(acet-sysvar-set '("cmdecho" 0 "osmode" 0))
(setq #dold (getvar "offsetdist"))
(cond ((setq ss (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
(if (null
(setq #d (getdist (strcat "\nOffsetdist <" (rtos #dold 2 2) ">")))
)
(setq #d #dold)
(setvar "offsetdist" #d)
)
(foreach ent (acet-ss-to-list ss)
(setq obj (vlax-ename->vla-object ent)
bit (GetA (acet-geom-vertex-list ent))
)
(if (vlax-method-applicable-p obj 'Offset)
(cond ((< bit 0) (vlax-invoke obj 'Offset #d))
((> bit 0) (vlax-invoke obj 'Offset (- #d)))
)
)
)
)
(T (princ "\nNo thing to do"))
)
(acet-sysvar-restore)
(vla-EndUndoMark ActDoc)
(princ)
)
<<
|
Tác giả: m4u_and1
Bài viết gốc: 143169
Tên lệnh: tt |
Viết lisp theo yêu cầu [phần 2]
Bạn dùng cái này thử xem.
(defun c:tt (/ A B)
(if (setq A (nentsel "\nCh\U+1ECDn text ngu\U+1ED3n :"))
(progn
(setq A (cdr (assoc 1...
>>
Bạn dùng cái này thử xem.
(defun c:tt (/ A B)
(if (setq A (nentsel "\nCh\U+1ECDn text ngu\U+1ED3n :"))
(progn
(setq A (cdr (assoc 1 (entget (car A)))))
(while (setq B (car (nentsel "\nCh\U+1ECDn text b\U+1ECB thay th\U+1EBF :")))
(entmod
(subst
(cons 1 A)
(assoc 1 (entget B))
(entget B)
) ;_ end of subst
) ;_ end of entmod
) ;_ end of while
) ;_ end of progn
) ;_ end of if
(princ)
) ;_ end of defun
P/S : match được cả các text trong block :)
Cảm ơn bác rất nhiều.
Lisp của bác rất hữu ích cho em ạ. Em chỉ góp ý thêm chút xíu thôi thế này được không: bác làm sao cho cái lisp này khi sử dụng mình có thể khoanh xung quanh các đối tượng được chọn chứ không đơn thuần là pick vào đối tượng được chọn. Vì em thấy nếu theo lisp thì khi pick trật khỏi text là nó tự kết thúc lệnh luôn. hehe. Em làm phiền bác tí vậy :P
<<
|
Tác giả: DungNguyen685
Bài viết gốc: 457478
Tên lệnh: loff lon |
Giúp đỡ lisp ẩn 1 layer cố định
Mục đích để làm gì ? Có vẻ khá phụ thuộc lisp nhỉ.
(Defun C:Loff ()
(setvar "cmdecho" 0)
(setq LAY "dimension")
(if (= LAY (getvar "clayer"))
(princ
(strcat "\nLayer " LAY " khong the FRZ (Layer hien hanh).")
)
(progn (command "_.LAYER" "FREEZE" LAY "")
(princ (strcat "\nLayer " LAY " da FRZ."))
)
)
(princ)
)
(Defun C:Lon ()
(setvar "cmdecho" 0)
...
>>
Mục đích để làm gì ? Có vẻ khá phụ thuộc lisp nhỉ.
(Defun C:Loff ()
(setvar "cmdecho" 0)
(setq LAY "dimension")
(if (= LAY (getvar "clayer"))
(princ
(strcat "\nLayer " LAY " khong the FRZ (Layer hien hanh).")
)
(progn (command "_.LAYER" "FREEZE" LAY "")
(princ (strcat "\nLayer " LAY " da FRZ."))
)
)
(princ)
)
(Defun C:Lon ()
(setvar "cmdecho" 0)
(Command "_.LAYER" "_THAW" "*" "")
(princ)
)
P/s Chỉ sửa lại tí của lisp bạn nào đó chia sẻ.
<<
|
|
Filename: 457478_loff_lon.lsp
|
|
Tác giả: alisp
Bài viết gốc: 457554
Tên lệnh: taborder |
Rắc Rối Khi Layout Khong Theo Thứ Tự Các Căn Như Ý Muốn
;; 2002 by Luis Esquivel
(defun C:TABORDER (/ cnt)
(vl-load-com)
(setq cnt 1)
(foreach lay (acad_strlsort (layoutlist))
(vla-put-taborder (vla-item (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object))) lay) cnt)
(setq cnt (1+ cnt))
)
(princ)
)
Cho bạn cái này, của tác giả trong lisp. Tên lệnh Taborder.
|
|
Filename: 457554_taborder.lsp
|
|
Tác giả: 888x888x888
Bài viết gốc: 457599
Tên lệnh: bao |
Nhờ chỉnh sửa lisp tạo đường bao
Mình tìm thấy lisp này trên diễn đàn,
Lisp dùng khá ok nhưng lại tạo đường bo ở dạng Region,
Mình muốn đường bo thành dạng polyline, Bác nào sửa giúp mình với ạ
Thank
(defun c:bao()
(setq p (getpoint "pick diem :"))
(command "._boundary" "A" "O" "R" "" p "")
(Command "._region" "L" "")
(setq el (entlast)) (redraw el...
>>
Mình tìm thấy lisp này trên diễn đàn,
Lisp dùng khá ok nhưng lại tạo đường bo ở dạng Region,
Mình muốn đường bo thành dạng polyline, Bác nào sửa giúp mình với ạ
Thank
(defun c:bao()
(setq p (getpoint "pick diem :"))
(command "._boundary" "A" "O" "R" "" p "")
(Command "._region" "L" "")
(setq el (entlast)) (redraw el 3)
(while (setq p (getpoint "pick diem :"))
(command "._boundary" p "")
(Command "._region" "L" "")
(command "._union" el "L" "")
(setq el (entlast))
(redraw el 3)
)
)
<< |
Tác giả: Tr.CongSon
Bài viết gốc: 365335
Tên lệnh: cm |
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Chào các anh chị,
Em mới học Lisp,mong mọi người giúp đỡ nhiều ạ
Em có đoạn Code sau
>>
Chào các anh chị,
Em mới học Lisp,mong mọi người giúp đỡ nhiều ạ
Em có đoạn Code sau
(defun c:CM (/ *error* cla ent-last iferror k lay olderr os r ve vec);;;; tao cloud mark;
(setvar "modemacro" "CREATE CLOUD_MARK")
;;; (setvar "CMDECHO" 0)
(command "undo" "BE")
(defun iferror (msg)
(if (= cla nil)
(setq cla "3"))
(if cla (setvar "CLAYER" cla))
(if os (setvar "OSMODE" os))
(setvar "CMDECHO" 1)
(setq *error* olderr)
(princ)
)
(setq lay (tblsearch "layer" "Cloud mark"))
(if (= lay nil)
(command "_layer" "_n" "Cloud mark" "_c" "6" "Cloud mark" ""))
(setq olderr *error*)
(setq *error* iferror)
(graphscr)
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq cla (getvar "CLAYER"))
(setq r (* (getvar "DIMSCALE") 5))
(setq k T)
(while k
(terpri)
(if (= ve nil) (setq ve "Hinh chu nhat"))
(setq vec (strcat "\nVe hinh chu nhat hay duong line? <" ve ">: "))
(setq vec (getstring vec))
(if (= vec "")
(command "_.RECTANGLE")
(command "_.pline"))
(while (= 1 (getvar "cmdactive")) (command pause))
(setq ent-last (entlast))
(setvar "clayer" "Cloud mark")
(command "_.REVCLOUD" "_A" r r "_Object" ent-last "")
)
(setvar "CLAYER" cla)
(setq *error* olderr)
(setvar "OSMODE" os)
(command "undo" "End")
;;; (setvar "CMDECHO" 1)
(princ)
)
Chào các anh chị,
Lâu nay e dùng Lisp này khi tạo đám mây nó sẽ tự xóa đối tượng cũ đi ,Tự nhiên mấy hôm ni không biết nghịch dại,không biết sao nó ko tự Delete đối tượng cũ khi tạo đám mây đi ạ,
Mong anh chị giải đáp giúp để em có thể học hỏi thêm !
P/s:Nếu dùng Lisp để xóa thì em làm được,như ng em nghĩ do thay đổi biến hệ thống nào đó liên quan đến Lệnh REVCLOUD nên nó mới thay đổi thế ạ,
File đây ạ : http://www.cadviet.com/upfiles/5/142392_cloudmark.dwg
<<
|
Tác giả: gia_bach
Bài viết gốc: 104910
Tên lệnh: xtxt |
Viết giúp Lisp xoá text trong khoảng nhất định
Chào bạn thanhduan2407, Trong lúc bác Giabach đang bận, mình viết thử cái này để bạn dùng thử xem có đạt yêu cầu không nhé. Lisp mình viết dựa trên cái file...
>>
Chào bạn thanhduan2407, Trong lúc bác Giabach đang bận, mình viết thử cái này để bạn dùng thử xem có đạt yêu cầu không nhé. Lisp mình viết dựa trên cái file chứa các text mẫu mà bạn đã gửi và đã tess thử trên đó thấy OK. Bạn dùng thử nếu thấy có gì chưa hợp ý hãy pót lên vì có thể mình chưa hiểu đúng ý bạn.Bạn thông cảm nhé vì mình không phải có cùng chuyên môn với bạn.
Khi lisp yêu cầu bạn nhập tên file lưu số liệu bạn nhớ nhập cái tên bạn muốn và lưu ý nó để mở lại sau này. Lisp này chỉ lưu lại các giá trị X,Y,Z chứ chưa có STT như bạn đã post.
Chúc bạn vui.
(defun c:xtxt (/ p1 p2 ss n i plist polst en els pt ss1 m j en1 els1 pt1 txtail txtint txtz
txtlst tmp fil pos z )
(command "undo" "be")
(setq p1 (getpoint "\n Chon diem dau")
p2 (getpoint p1 "\n Chon diem thu hai"))
(setq ss (ssget "w" p1 p2 '((0 . "Point")))
n (sslength ss)
i 0
plist (list)
polst (list)
)
(while (< i n)
(setq en (ssname ss i)
els (entget en)
pt (cdr (assoc 10 els))
ss1 (ssget "w" p1 p2 '((0 . "text")))
m (sslength ss1)
j 0
plist (append plist (list pt))
)
(While (< j m)
(setq en1 (ssname ss1 j)
els1 (entget en1)
pt1 (cdr (assoc 11 els1))
)
(if (and (= (cdr (assoc 72 els1)) 0) (= (cdr (assoc 73 els1)) 3) (equal pt pt1))
(setq txtail (cdr (assoc 1 els1))))
(if (and (= (cdr (assoc 72 els1)) 2) (= (cdr (assoc 73 els1)) 1) (equal pt pt1))
(progn
(setq txtint (cdr (assoc 1 els1)))
(if (= (substr txtint 1 3) "%%U")
(setq txtint (substr txtint 4))
(setq txtint (strcat "-" txtint ))
)
)
)
(setq j (1+ j))
)
(setq txtz (strcat txtint "." txtail)
txtlst (list txtz)
plist (append plist txtlst)
)
(setq polst (append polst (list plist))
plist (list))
(setq i (1+ i))
)
(if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
(setq fil (open tmp "w") )
(foreach pos polst
(setq z (cadr pos))
(write-line (strcat (rtos (car (car pos))) (chr 44) (rtos (cadr (car pos))) (chr 44) z) fil)
)
(close fil) ))
(command "undo" "e")
(princ)
)
Chào bác phamthanhbinh
Xin có góp ý với bác về Lisp xtxt
- mặc dù là Lisp cho kết quả chính xác nhưng với dòng
(ssget "w" p1 p2 '((0 . "text")))
bác phải lần luợt duyệt qua toàn bộ tập hợp chọn này để tìm ra cặp có cùng insert point (với file có nhiều Text thì thời gian này là đáng kể).
Trong khi đó cặp Text này luôn có vị trí điểm chèn trùng với điểm chèn của POINT, vây ta có thể rút gọn bộ tập hợp chọn này bằng:
(ssget pt '((0 . "text")))
hay an toàn hơn
(ssget "_C" (polar pt (/ (* 3 pi) 4) hTxt) (polar pt (/ pi -4) hTxt) (list (cons 0 "TEXT") ) )
với hTxt là chiều cao của Text.
Chúc bác sức khỏe!
<<
|
|
Filename: 104910_xtxt.lsp
|
|
Tác giả: naturooo
Bài viết gốc: 457847
Tên lệnh: qf |
Lisp Quick Filter: Lọc nhanh theo một số thuộc tính thông dụng
42 phút trước, tranhoang1218 đã nói:
42 phút trước, tranhoang1218 đã nói:
Em có tải thử và sử dụng lisp, thấy khá tiện, mà không biết cách viết thêm để show 1 tính chất là dimstyle ấy ạ, Bác Naturooo có thể add thêm giúp em với hoặc chỉ em cách thêm được không ạ. Đa tạ bác nhiều.
Đây nhé bạn:
;; List Box - Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - Dialog label
;; lst - List of strings to display
;; bit - 1=allow multiple; 2=return indexes
;; Returns: List of selected items/indexes, else nil
(defun LM:listbox (msg lst bit / dch des tmp rtn)
(cond
((not
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(write-line
(strcat "listbox:dialog{label=\""
msg
"\";spacer;:list_box{key=\"list\";multiple_select="
(if (= 1 (logand 1 bit))
"true"
"false"
)
";width=50;height=15;}spacer;ok_cancel;}"
)
des
)
(not (close des))
(< 0 (setq dch (load_dialog tmp)))
(new_dialog "listbox" dch)
)
)
(prompt "\nError Loading List Box Dialog.")
)
(t
(start_list "list")
(foreach itm lst (add_list itm))
(end_list)
(setq rtn (set_tile "list" "0"))
(action_tile "list" "(setq rtn $value)")
(setq rtn
(if (= 1 (start_dialog))
(if (= 2 (logand 2 bit))
(mapcar '(lambda (x) (nth x lst))
(read (strcat "(" rtn ")"))
)
(read (strcat "(" rtn ")"))
; (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
)
)
)
)
)
(if (< 0 dch)
(unload_dialog dch)
)
(if (and tmp (setq tmp (findfile tmp)))
(vl-file-delete tmp)
)
rtn
)
;====================================Main Lisp: Quick Filter (QF) Update 19/08/2020 Loc theo "True Color"======================================
(defun C:QF (/ ss ss1 ob lyrname colr blkname
txth txtn txtvl lstQF lstDCL lstidx dimsty lstfi a c
d l
)
(setq ss1 (entsel "\nSelect Object: "))
(while (or
(null ss1)
(= "" (cdr (assoc 0 (entget (car ss1)))))
)
(setq ss1 (entsel "\nSelect Object Again: "))
)
(setq ss (entget (car ss1)))
(setq ob (cdr (assoc 0 ss)))
(setq lstQF (list (cons 0 ob)))
(if (= "INSERT" ob)
(setq lstDCL (list (strcat "Object : " "Block")))
(setq lstDCL (list (strcat "Object : " ob)))
);endif
(setq lyrname (cdr (assoc 8 ss)))
(setq lstQF (append lstQF (list (cons 8 lyrname))))
(setq lstDCL (append lstDCL
(list (strcat "Layer : " lyrname))
)
)
(setq c
(cond
((cdr (assoc 62 ss)))
((abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ss)))))
)
)
)
)
(while (setq d (tblnext "LAYER" (null d)))
(if (= c (abs (cdr (assoc 62 d))))
(setq l (cons "," (cons (cdr (assoc 2 d)) l)))
)
)
(setq lstQF (append lstQF (list "True Color")))
(setq lstDCL (append lstDCL (list (strcat "True Color : " (rtos c 2 0))) ) )
(if (= 2 (car (assoc 2 ss)))
(progn
(setq blkname (cdr (assoc 2 ss)))
(setq lstQF (append lstQF (list (cons 2 blkname))))
(setq
lstDCL (append lstDCL
(list (strcat "Block Name : " blkname))
)
)
) ;end progn
) ;end if
(if (= 40 (car (assoc 40 ss)))
(progn
(setq txth (cdr (assoc 40 ss)))
(setq lstQF (append lstQF (list (cons 40 txth))))
(setq lstDCL
(append lstDCL
(list (strcat "Text Height : " (rtos txth)))
)
)
) ;end progn
) ;end if
(if (= 7 (car (assoc 7 ss)))
(progn
(setq txtn (cdr (assoc 7 ss)))
(setq lstQF (append lstQF (list (cons 7 txtn))))
(setq lstDCL (append lstDCL
(list (strcat "Text Style Name : " txtn))
)
)
);end progn
);end if
(if (= 1 (car (assoc 1 ss)))
(progn
(setq txtvl (cdr (assoc 1 ss)))
(setq lstQF (append lstQF (list (cons 1 txtvl))))
(setq lstDCL (append lstDCL
(list (strcat "Text Value : " txtvl))
)
)
);end progn
);end if
(if (= 3 (car (assoc 3 ss)))
(progn
(setq dimsty (cdr (assoc 3 ss)))
(setq lstQF (append lstQF (list (cons 3 dimsty))))
(setq lstDCL (append lstDCL
(list (strcat "Dimension Style : " dimsty))
)
)
);end progn
);end if
(setq lstidx (LM:listbox "Selection to Filter:" lstDCL 1))
(if lstidx
(progn
(foreach a lstidx
(if (= "True Color" (nth a lstQF))
(if l
(setq lstfi (append lstfi
(list
(cons -4 "<OR")
(cons 62 c)
(cons -4 "<AND")
(cons 62 256)
(cons 8 (apply 'strcat (cdr l)))
(cons -4 "AND>")
(cons -4 "OR>")
)
))
(setq lstfi (append lstfi
(list (cons 62 c))
))
)
(setq lstfi (append lstfi (list (nth a lstQF))))
)
)
(sssetfirst nil); clear original-selection highlighting/gripping, then:
(sssetfirst nil (ssget lstfi))
)
)
(Print "Write by: NghiaKieu")
(princ)
)
<<
|
Tác giả: Oohlala
Bài viết gốc: 362510
Tên lệnh: m2v |
Nhờ các bạn giúp đỡ sửa lisp
(defun c:m2v (/ #app #doc *error* c cmd lay lst o sc vp)
(defun *error* (msg)
(and cmd (setvar 'cmdecho cmd))
(and...
>>
(defun c:m2v (/ #app #doc *error* c cmd lay lst o sc vp)
(defun *error* (msg)
(and cmd (setvar 'cmdecho cmd))
(and #doc (vla-endundomark #doc))
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
(princ (strcat "\nError: " msg))
)
)
(setq #app (vlax-get-acad-object)
#doc (vla-get-activedocument #app)
cmd (getvar 'cmdecho))
(if (= 0 (vla-get-activespace #doc)) (vla-put-activespace #doc 1))
(if (and (princ "\nSelect a Closed LwPolyline: ")
(setq o (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (70 . 1))))
(setq o (ssname o 0))
(setq c (pline-centroid o))
(setq o (vlax-ename->vla-object o))
(setq sc (distof (getstring "\nEnter Scale for new Viewport: ")))
(setq sc (/ 1.0 sc))
)
(progn
(vlax-for lay (vla-get-layouts #doc)
(if (/= "MODEL" (strcase (vla-get-name lay)))
(setq lst (cons (cons (vla-get-name lay) lay) lst))
)
)
(if (setq lst
(mapcar
'(lambda (x) (cdr (assoc x lst)))
(LM:Listbox
"Choose Layout to create ViewPort"
(mapcar 'car
(vl-sort lst
'(lambda (a b)
(< (vla-get-taborder (cdr a))
(vla-get-taborder (cdr b))
)
)
)
)
t
)
)
)
(progn
(vla-startundomark #doc)
(LM:loadlinetypes '("hidden") nil)
(setvar 'cmdecho 0)
(foreach lay lst
(vla-put-activelayout #doc lay)
(setq vp (vlax-vla-object->ename
(car (vlax-invoke
#doc
'copyobjects
(list o)
(vla-get-block lay)
)
)
)
)
(vla-put-linetype (vlax-ename->vla-object vp) "hidden")
(vl-cmdf "_.mview" "_object" vp)
(setq vp (vlax-ename->vla-object (entlast)))
(vla-put-linetype vp "hidden")
(vla-display vp :vlax-true)
(vla-put-mspace #doc :vlax-true)
(vla-put-ActivePViewport #doc vp)
(vla-zoomCenter #app (vlax-3d-point c) 1.0)
(vla-put-mspace #doc :vlax-false)
(vla-put-customscale vp sc)
(VLA-ZoomObject vp)
)
)
)
)
)
(*error* nil)
(princ)
)
;;==================================================================;;
;;======================== SUB FUNCTION ============================;;
;;==================================================================;;
;;=================== POLYLINE CENTROID BY GILE=====================;;
;; ALGEB-AREA
;; Returns tha algebraic area of the triangle defined by 3 2d points
;; the area is negative if points are clockwise
(defun algeb-area (p1 p2 p3)
(/ (- (* (- (car p2) (car p1))
(- (cadr p3) (cadr p1))
)
(* (- (car p3) (car p1))
(- (cadr p2) (cadr p1))
)
)
2.0
)
)
;; TRIANGLE-CENTROID
;; Returns the centroid of a triangle defined by 3 points
(defun triangle-centroid (p1 p2 p3)
(mapcar '(lambda (x1 x2 x3)
(/ (+ x1 x2 x3) 3.0)
)
p1
p2
p3
)
)
;; POLYARC-CENTROID
;; Returns a list which first item is the centroid of a 'polyarc'
;; and the second its algeraic area
;;
;; Arguments
;; bu : polyarc bulge
;; p1 : start point
;; p2 : end point
(defun polyarc-centroid (bu p1 p2 / ang rad cen area dist cg)
(setq ang (* 2 (atan bu))
rad (/ (distance p1 p2)
(* 2 (sin ang))
)
cen (polar p1
(+ (angle p1 p2) (- (/ pi 2) ang))
rad
)
area (/ (* rad rad (- (* 2 ang) (sin (* 2 ang)))) 2.0)
dist (/ (expt (distance p1 p2) 3) (* 12 area))
cg (polar cen
(- (angle p1 p2) (/ pi 2))
dist
)
)
(list cg area)
)
;; PLINE-CENTROID
;; Returns the WCS coordinates of a lwpolyline centroid
;;
;; Argument
;; pl : the lwpolyline ename
(defun pline-centroid (pl / elst lst tot cen p0 area cen)
(setq elst (entget pl))
(while (setq elst (member (assoc 10 elst) elst))
(setq lst (cons (cons (cdar elst) (cdr (assoc 42 elst))) lst)
elst (cdr elst)
)
)
(setq lst (reverse lst)
tot 0.0
cen '(0.0 0.0)
p0 (caar lst)
)
(if (/= 0 (cdar lst))
(setq p-c (polyarc-centroid (cdar lst) p0 (caadr lst))
cen (mapcar '(lambda (x) (* x (cadr p-c))) (car p-c))
tot (cadr p-c)
)
)
(setq lst (cdr lst))
(if (equal (car (last lst)) p0 1e-9)
(setq lst (reverse (cdr (reverse lst))))
)
(while (cadr lst)
(setq area (algeb-area p0 (caar lst) (caadr lst))
cen (mapcar '(lambda (x1 x2) (+ x1 (* x2 area)))
cen
(triangle-centroid p0 (caar lst) (caadr lst))
)
tot (+ area tot)
)
(if (/= 0 (cdar lst))
(setq p-c (polyarc-centroid (cdar lst) (caar lst) (caadr lst))
cen (mapcar '(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
cen
(car p-c)
)
tot (+ tot (cadr p-c))
)
)
(setq lst (cdr lst))
)
(if (/= 0 (cdar lst))
(setq p-c (polyarc-centroid (cdar lst) (caar lst) p0)
cen (mapcar '(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
cen
(car p-c)
)
tot (+ tot (cadr p-c))
)
)
(trans (list (/ (car cen) tot)
(/ (cadr cen) tot)
(cdr (assoc 38 (entget pl)))
)
pl
0
)
)
;;-----------------------=={ List Box }==---------------------;;
;; ;;
;; Displays a List Box allowing the user to make a selection ;;
;; from the supplied data. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; title - List Box Dialog title ;;
;; lst - List of Strings to display in the List Box ;;
;; multiple - Boolean flag to determine whether the user ;;
;; may select multiple items (T=Allow Multiple) ;;
;;------------------------------------------------------------;;
;; Returns: List of selected items, else nil. ;;
;;------------------------------------------------------------;;
(defun LM:ListBox ( title lst multiple / dch des tmp res )
(cond
( (not
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(write-line
(strcat
"listbox : dialog { label = \""
title
"\"; spacer; : list_box { key = \"list\"; multiple_select = "
(if multiple "true" "false")
"; } spacer; ok_cancel; }"
)
des
)
(not (close des))
(< 0 (setq dch (load_dialog tmp)))
(new_dialog "listbox" dch)
)
)
(prompt "\nError Loading List Box Dialog.")
)
( t
(start_list "list")
(foreach item lst (add_list item))
(end_list)
(setq res (set_tile "list" "0"))
(action_tile "list" "(setq res $value)")
(setq res
(if (= 1 (start_dialog))
(mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" res ")")))
)
)
)
)
(if (< 0 dch)
(unload_dialog dch)
)
(if (and tmp (setq tmp (findfile tmp)))
(vl-file-delete tmp)
)
res
)
;; Load Linetypes - Lee Mac
;; Attempts to load a list of linetypes from any .lin files found in the support path.
;; Excludes known metric & imperial definition files based on the value of MEASUREMENT
;; lts - List of linetypes to load
;; rdf - If T, linetypes will be redefined from file if already loaded
;; Returns: T if all linetypes are loaded successfully, else nil
(defun LM:loadlinetypes ( lts rdf / lst ltc rtn val var )
(if (zerop (getvar 'measurement))
(setq lst (mapcar 'strcase '("acadiso.lin" "iso.lin"))) ;; Known metric .lin files
(setq lst (mapcar 'strcase '("acad.lin" "default.lin"))) ;; Known imperial .lin files
)
(setq ltc (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object)))
var '(cmdecho expert)
val (mapcar 'getvar var)
lst (vl-remove-if '(lambda ( x ) (member (strcase x) lst))
(apply 'append
(mapcar '(lambda ( dir ) (vl-directory-files dir "*.lin" 1))
(vl-remove "" (LM:str->lst (getenv "ACAD") ";"))
)
)
)
)
(mapcar 'setvar var '(0 5))
(setq rtn
(apply 'and
(mapcar
'(lambda ( typ )
(cond
( (not (tblsearch "ltype" typ))
(vl-some
'(lambda ( lin )
(vl-catch-all-apply 'vla-load (list ltc typ lin))
(tblsearch "ltype" typ)
)
lst
)
)
( rdf
(vl-some
'(lambda ( lin )
(and (LM:ltdefined-p typ lin)
(vl-cmdf "_.-linetype" "_L" typ lin "")
(tblsearch "ltype" typ)
)
)
lst
)
)
( t )
)
)
lts
)
)
)
(mapcar 'setvar var val)
rtn
)
;; Linetype Defined-p - Lee Mac
;; Returns T if the linetype is defined in the specified .lin file
;; ltp - Linetype name
;; lin - Filename of linetype definition file (.lin)
(defun LM:ltdefined-p ( ltp lin / str rtn )
(if
(and
(setq lin (findfile lin))
(setq lin (open lin "r"))
)
(progn
(setq ltp (strcat "`*" (strcase ltp) "`,*"))
(while
(and (setq str (read-line lin))
(not (setq rtn (wcmatch (strcase str) ltp)))
)
)
(close lin)
rtn
)
)
)
;; String to List - Lee Mac
;; Separates a string using a given delimiter
;; str - String to process
;; del - Delimiter by which to separate the string
;; Returns: List of strings
(defun LM:str->lst ( str del / pos )
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del))
(list str)
)
)
(defun VLA-ZoomObject (obj / minPt maxPt)
(vla-GetBoundingBox obj 'minPt 'maxpt)
(vla-ZoomWindow (vlax-get-acad-object) minPt maxpt)
)
(vl-load-com)
;|«Visual LISP© Format Options»
(70 2 1 2 nil "_eof " 100 9 0 0 1 T T T T)
;*** DO NOT add text below the comment! ***|;
bạn ơi cái lsp của bạn mình dùng toàn báo lỗi. khi pick xong polyline, nhập tỷ lệ ( vd 1/100 ) , chọn layout, xong nó tự động chuyển sang layout đã đc chọn, rồi chẳng có gì hiện ra và nó báo lỗi thế này Clip entity not currently regen'ed. ActiveX Server returned the error: unknown name: DisplaySelect object to clip viewport:
<<
|
Tác giả: thiep
Bài viết gốc: 458079
Tên lệnh: gdt |
Nhờ code lisp lấy toạ độ điểm giao của rectang or pline or line
Lisp của bạn, các toạ độ góc được gắn vào biến polst
(defun sysvar-set (lst_setvar / strN var var_oldname n)
(setq n 0
lstvar_thiep nil
lstValue_thiep nil
)
(repeat (/ (length lst_setvar) 2)
(setq var (nth n lst_setvar)
var_oldname (strcat "oldvar_thiep" (itoa n))
)
(setq lstvar_thiep (append lstvar_thiep (list...
>>
Lisp của bạn, các toạ độ góc được gắn vào biến polst
(defun sysvar-set (lst_setvar / strN var var_oldname n)
(setq n 0
lstvar_thiep nil
lstValue_thiep nil
)
(repeat (/ (length lst_setvar) 2)
(setq var (nth n lst_setvar)
var_oldname (strcat "oldvar_thiep" (itoa n))
)
(setq lstvar_thiep (append lstvar_thiep (list var)))
(set (read var_oldname) (getvar var))
(setq lstValue_thiep (append lstValue_thiep (list (read var_oldname))))
(setvar var (nth (+ n 1) lst_setvar))
(setq n (+ 2 n))
)
)
(defun c:gdt (/ ucshold po ent_bo polst lstvar_thiep lstValue_thiep)
(sysvar-set '("cmdecho" 0 "osmode" 0))
(setq ucshold (acet-ucs-get nil))
(acet-ucs-cmd '("w"))
(setq po (getpoint "\Pick a point inside the closed boundary "))
(command "_.-boundary" po "")
(if (and (setq ent_bo (entlast)) (eq (acet-dxf 0 (entget ent_bo)) "LWPOLYLINE"))
(progn (setq polst (acet-geom-object-point-list ent_bo nil))
(if (equal (car polst) (last polst) 0.01)
(setq polst (cdr polst))
)
(entdel ent_bo)
)
)
(acet-ucs-set ucshold)
(mapcar '(lambda (var value) (setvar var (eval value)))
lstvar_thiep
lstValue_thiep
)
(and polst(princ polst))
(princ)
)
<< |
Tác giả: se7en
Bài viết gốc: 12498
Tên lệnh: tarb |
liên kết text diện tích và boundary
Mới sưu tầm cái lisp ghi diện tích của boundary và liên kết diện tích với boundary đó, nghĩa là khi thay đổi boundary, diện tích tự động thay đổi theo. lệnh có hai tùy... >>
Mới sưu tầm cái lisp ghi diện tích của boundary và liên kết diện tích với boundary đó, nghĩa là khi thay đổi boundary, diện tích tự động thay đổi theo. lệnh có hai tùy chọn: B dùng để tạo boundary và ghi diện tích; L để ghi diện tích cho boundary có sẵn. Tặng các bạn , ai thích thì xài:(lệnh là tarb)
(defun ufa (notifier-object reactor-object parameter-list)
(vl-load-com)
(cond
((vlax-property-available-p notifier-object "Area")
(setq actDoc
(vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-SAVE actDoc)
)
)
)
(defun plar(/ pt pt1 pt2)
(setq pt (getpoint"\nStarting Point: "))
(setq pt1 (getpoint pt "\nNext Point: "))
(command "Pline" pt pt1 "")
(while
(setq pt2 (getpoint pt1"\nNext Point: "))
(command "pline" "" pt2 "")
(command "pedit" pt "j" pt pt2 "" "")
(setq pt1 pt2)
)
(command "pedit" pt "c" "")
(princ)
)
(defun ar5 ()
(SETQ A NIL)
(vl-load-com)
(setq cm (getvar "cmdecho"))
(setvar"cmdecho" 0)
(setq fd (getvar "fielddisplay"))
(if (/= fd 0)(setvar"fielddisplay" 0))
(setq ar1 (entsel "\nSelect Area Boundary: "))
(setq ar2 (car ar1))
(setq tab (vlax-ename->vla-object ar2))
(setq oba (vla-get-objectid tab))
(setq lu (getvar "lunits"))
(setq tpt (getpoint"\nSelect Area Text Point: "))
(cond
((= lu 2) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos oba 2 0) ">%).Area \\f \"%lu6%qf1\">%")))
((= lu 4) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 5) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos oba 2 0) ">%).Area \\f \"%lu5\">%")))
((= lu 3) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 1) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos oba 2 0) ">%).Area \\f \"%lu1\">%")))
)
(command "mtext" tpt "w" "0" lin "")
(setq plineReactor (vlr-object-reactor (list tab) "pline Reactor" '((:vlr-modified . ufa))))
(princ)
)
(defun c:tarb (/ key)
(initget 1 "Boundary/label-area Label-area")
(setq key (getkword "\nWould you like Boundary/label-area or Label-area: "))
(cond
((= key "Boundary/label-area")(plar)(ar5))
((= key "Label-area")(ar5))
)
(princ)
)
CAD báo lỗi bạn ơi : ; error: AutoCAD variable setting rejected: "fielddisplay" 0
<<
|