Một số lisp sưu tầm
Tổng hợp một số lisp tạo wipeout từ các đối tượng có sẵn:
- WB (đã chỉnh sửa): Tạo Wipout từ Block
Nguyên lý tạo Wipeout của WB là tìm outline dựa trên các đường line có thể khép kín. Do đó, block cần tạo Wipeout cần có thể xác định được 1 đường bao kín.
WB sử dụng một số thuật toán của LeeMac từ lee-mac.com
WB có thể gặp lỗi với một số block có hình dạng phức tạp, nhiều chi tiết.
- CBC: Tạo Wipeout từ Cirlce hoặc Elipse
Mã nguồn
1 Thêm WB.lsp
Lưu mã sau dưới dạng tệp tin WB_.lsp
Code:
(defun c:wb (/ ss result idx maxArea maxEnt ent lst nor wipe blEnt area)
(vl-load-com)
(if (setq ss (ssget "_:L" '((0 . "*")))) ; Chọn bất kỳ đối tượng nào
(progn
(LM:startundo (LM:acdoc))
;; Tạo đường bao
(setq result (LM:outline ss))
;; Tìm đường bao lớn nhất
(setq idx 0 maxArea 0.0 maxEnt nil)
(while (< idx (sslength result))
(setq ent (ssname result idx))
(if (and (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
(vlax-property-available-p (vlax-ename->vla-object ent) 'Area)
(setq area (vla-get-Area (vlax-ename->vla-object ent)))
(> area maxArea))
(setq maxArea area
maxEnt ent)
)
(setq idx (1+ idx))
)
;; Nếu tìm được đường bao
(if maxEnt
(progn
(setq lst (ent2ptlst maxEnt)
nor '(0.0 0.0 1.0))
;; Tạo wipeout
(MakeWipeout lst nor)
(setq wipe (entlast))
;; Wipeout đứng trên các đối tượng khác
(command "_.draworder" wipe "" "front")
;; Các đối tượng được chọn đứng trên wipeout
(command "_.draworder" ss "" "front")
;; Xóa đường bao tạm
(setq idx 0)
(while (< idx (sslength result))
(entdel (ssname result idx))
(setq idx (1+ idx))
)
;; Hỏi có chèn vào block không
(initget "Yes No")
(if (= (getkword "\nDo you want to insert wipeout into a block? [Yes/No] <No>: ") "Yes")
(progn
(setq blEnt (car (entsel "\nSelect block reference: ")))
(if (and blEnt (= "INSERT" (cdr (assoc 0 (entget blEnt)))))
(progn
(AddEntityToBlock wipe blEnt)
(princ "\nWipeout was added to block.")
)
(princ "\nInvalid block selected.")
)
)
)
;; Hỏi có xóa wipeout không
;(initget "Yes No")
;(if (= (getkword "\nDelete wipeout? [Yes/No] <No>: ") "Yes")
;(entdel wipe)
;)
)
(princ "\nKhông tìm được đường bao phù hợp.")
)
(LM:endundo (LM:acdoc))
)
)
(princ)
)
(defun AddEntityToBlock (ent blk / mat obj blkname)
(setq obj (vlax-ename->vla-object ent)
blkname (cdr (assoc 2 (entget blk)))
mat (apply
(function
(lambda (mat vec)
(vlax-tmatrix
(append
(mapcar (function (lambda (x v) (append x (list v)))) mat vec)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(revrefgeom blk)
)
)
(vla-transformby obj mat)
(vla-copyobjects
(LM:acdoc)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 . 0))
(list obj)
)
)
(vla-item (vla-get-blocks (LM:acdoc)) blkname)
)
(vla-delete obj)
)
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Outline Objects - Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
;; sel - [sel] Selection Set to outline
;; Returns: [sel] A selection set of all objects created
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(if (setq box (LM:ssboundingbox sel))
(progn
(setq app (vlax-get-acad-object)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
)
)
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd)
)
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command
"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
)
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4)
)
(entdel enl)
(ssadd enl rtn)
)
)
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
rtn
)
)
)
;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS
(defun ent2ptlst (ent / obj dist n lst p_lst prec)
(vl-load-com)
(if (= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
(cond
((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
50
)
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
(vlax-get obj 'Normal)
)
lst
)
)
)
)
(T
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 42)
)
)
(entget ent)
)
)
(while p_lst
(setq
lst
(cons
(append (cdr (assoc 10 p_lst))
(list (cdr (assoc 38 (entget ent))))
)
lst
)
)
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
dist (/ (- (if (cdaddr p_lst)
(vlax-curve-getDistAtPoint
obj
(trans (cdaddr p_lst) ent 0)
)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
(vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst (cons
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
(* dist (setq n (1+ n)))
)
)
0
ent
)
lst
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
lst
)
;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object
(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
(setq dxf10 (list (apply 'min (mapcar 'car pt_lst))
(apply 'min (mapcar 'cadr pt_lst))
(caddar pt_lst)
)
)
(setq
max_dist
(float
(apply 'max
(mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
)
)
)
(setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
(setq
dxf14 (mapcar
'(lambda (p)
(mapcar '/
(mapcar '- p cen)
(list max_dist (- max_dist) 1.0)
)
)
pt_lst
)
)
(setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
(entmake (append (list '(0 . "WIPEOUT")
'(100 . "AcDbEntity")
'(100 . "AcDbWipeout")
'(90 . 0)
(cons 10 (trans dxf10 nor 0))
(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
'(13 1.0 1.0 0.0)
'(70 . 7)
'(280 . 1)
'(71 . 2)
(cons 91 (length dxf14))
)
(mapcar '(lambda (p) (cons 14 p)) dxf14)
)
)
)
;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box
(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
(vl-load-com) (princ)
(princ "\n[WB] Wipeout by boundary loaded. Type WB to use.")
(princ "\nEdited by lisp.vn.")
(princ)Link tải (MediaFire)
Bản chỉnh sửa
2 Thêm WB.lsp
Lưu mã sau dưới dạng tệp tin WB_.lsp
Code:
;; ==========================================================================
;; WIPEOUT BLOCK PRECISION (WB)
;; ==========================================================================
(defun c:WB (/ *error* doc tmp targetBlock ss ss1 i ent typeObj ptlst nor wipeObj boundRes tempEnt wipeList )
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun *error* (msg)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
(princ (strcat "\nLoi: " msg))
(princ "\nDa huy lenh.")
)
(LM:endundo doc)
(setvar 'cmdecho 1)
(princ)
)
(LM:startundo doc)
(setvar 'cmdecho 0)
(or mode (setq mode "No"))
(initget "Yes No")
(if (setq tmp (getkword (strcat "\nBan co muon chen Wipeout vao trong Block khong ? [Yes/No] <" mode ">: "))) (setq mode tmp))
(cond
( (= mode "Yes")
(while
(setq ent
(AT:GetSel entsel "\nChon cac block can tao wipeout: "
(lambda (x)
(and
(eq (cdr (assoc 0 (entget (car x)))) "INSERT")
(not (vlax-property-available-p (vlax-ename->vla-object (car x)) 'path))
(not (wcmatch (GET_EFFECTIVENAME_BLOCK (vlax-ename->vla-object (car x))) "`*[DTUPM]*"))
)
)
)
)
(setq targetBlock (car ent))
(setq wipeList (GetShapeWipeoutFromBlock targetBlock))
(if wipeList
(progn
(AddListToBlock wipeList targetBlock)
(princ (strcat "\n Da them Wipeout vao Block [" (GET_EFFECTIVENAME_BLOCK (vlax-ename->vla-object targetBlock)) "]."))
)
(princ "\n Khong tim thay duong bao khep kin cho Block nay.")
)
)
)
( (= mode "No")
(while (setq ent (car (AT:GetSel entsel "\nChon cac doi tuong (Circle/Ellipse/Pline/Block): " (lambda (x) (member (cdr (assoc 0 (entget (car x)))) '( "CIRCLE" "ELLIPSE" "LWPOLYLINE" "INSERT")) ))))
(setq typeObj (cdr (assoc 0 (entget ent))))
(setq wipeList nil)
(cond
( (and (= typeObj "INSERT")
(not (vlax-property-available-p (vlax-ename->vla-object ent) 'path))
(not (wcmatch (GET_EFFECTIVENAME_BLOCK (vlax-ename->vla-object ent)) "`*[DTUPM]*"))
)
(setq wipeList (GetShapeWipeoutFromBlock ent))
)
( (or (= typeObj "CIRCLE") (= typeObj "ELLIPSE")
(and (= typeObj "LWPOLYLINE") (= 1 (logand 1 (cdr (assoc 70 (entget ent))))))
)
(setq ptlst (ent2ptlst ent)
nor (cdr (assoc 210 (entget ent)))
)
(if (and ptlst (> (length ptlst) 2))
(progn
(MakeWipeout ptlst nor)
(setq wipeList (list (entlast)))
)
)
)
)
(if wipeList
(foreach w wipeList
(command "_.draworder" w "" "front")
(command "_.draworder" ent "" "front")
(if (and ptlst (setq ss1 (ssget "_WP" ptlst '((0 . "*"))))) (command "_.draworder" ss1 "" "front"))
)
)
)
)
(T (princ "\n Khong xac dinh duoc che do tao wipeout.\n"))
)
(LM:endundo doc)
(setvar 'cmdecho 1)
(princ)
)
;; ------------------- CAC HAM PHU TRO (CORE FUNCTIONS) --------------------------
;; Get effective block name By Pham Hoang Nhat
(defun GET_EFFECTIVENAME_BLOCK ( VlaObject / NameBlock)
(vl-catch-all-apply (function (lambda ( / )
(setq NameBlock (cdr (assoc 2 (entget (cdr (assoc 340 (entget (vlax-vla-object->ename (vla-item (vla-item (vla-GetExtensionDictionary VlaObject) "AcDbBlockRepresentation") "AcDbRepData")))))))))
)))
(if (not NameBlock)
(setq NameBlock (cdr (assoc 2 (entget (vlax-vla-object->ename VlaObject)))))
)
NameBlock
)
(defun GetShapeWipeoutFromBlock ( blkEnt / ssTemp result idx i ent ptlst nor wList )
(setq ssTemp (ssadd))
(ssadd blkEnt ssTemp)
(setq result (LM:outline ssTemp))
(setq wList '())
(setq idx 0 maxArea 0.0 maxEnt nil)
(while (< idx (sslength result))
(setq ent (ssname result idx))
(if (and (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
(vlax-property-available-p (vlax-ename->vla-object ent) 'Area)
(setq area (vla-get-Area (vlax-ename->vla-object ent)))
(> area maxArea)
)
(setq maxArea area
maxEnt ent
)
)
(setq idx (1+ idx))
)
(if maxEnt
(progn
(setq i 0)
(while (< i (sslength result))
(setq ent (ssname result i))
(if (equal maxEnt ent)
(progn
(setq ptlst (ent2ptlst ent)
nor '(0.0 0.0 1.0)
)
(MakeWipeout ptlst nor)
(setq wList (cons (entlast) wList))
)
)
(entdel ent)
(setq i (1+ i))
)
)
)
wList
)
(defun AddListToBlock (wipeObjList blkRef / blkName blkDef mat objList newObjs sa extDict sortTbl existObjs newWipeoutHandles newObjsList)
(setq blkName (GET_EFFECTIVENAME_BLOCK (vlax-ename->vla-object blkRef)))
(setq blkDef (vla-item (vla-get-blocks (LM:acdoc)) blkName))
;; Transform Matrix (World -> Block)
(setq mat (apply (function (lambda (mat vec) (vlax-tmatrix (append (mapcar (function (lambda (x v) (append x (list v)))) mat vec) '((0.0 0.0 0.0 1.0)))))) (revrefgeom blkRef)))
(setq objList '())
(foreach ent wipeObjList
(setq obj (vlax-ename->vla-object ent))
(vla-transformby obj mat)
(setq objList (cons obj objList))
)
(setq sa (vlax-make-safearray vlax-vbObject (cons 0 (1- (length objList)))))
(vlax-safearray-fill sa objList)
(setq newObjs (vla-copyobjects (LM:acdoc) (vlax-make-variant sa) blkDef))
(foreach obj objList (vla-delete obj))
;; FIX DRAW ORDER
(setq extDict (vla-GetExtensionDictionary blkDef))
(if (vl-catch-all-error-p (setq sortTbl (vl-catch-all-apply 'vla-Item (list extDict "ACAD_SORTENTS"))))
(setq sortTbl (vla-AddObject extDict "ACAD_SORTENTS" "AcDbSortentsTable"))
)
(setq newWipeoutHandles '())
(setq newObjsList (vlax-safearray->list (vlax-variant-value newObjs)))
(foreach no newObjsList (setq newWipeoutHandles (cons (vla-get-Handle no) newWipeoutHandles)))
(setq existObjs '())
(vlax-for item blkDef
(if (not (member (vla-get-Handle item) newWipeoutHandles))
(setq existObjs (cons item existObjs))
)
)
(if existObjs
(progn
(setq sa (vlax-make-safearray vlax-vbObject (cons 0 (1- (length existObjs)))))
(vlax-safearray-fill sa existObjs)
(vla-MoveToTop sortTbl (vlax-make-variant sa))
)
)
(vla-update (vlax-ename->vla-object blkRef))
(vla-regen (LM:acdoc) 1)
)
;----------------------------------------------------Lee Mac--------------------------------------------------------
(defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc))
(defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc))
(defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc)))
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(if (setq box (LM:ssboundingbox sel))
(progn
(setq app (vlax-get-acad-object)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
)
)
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd)
)
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command
"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
)
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4)
)
(entdel enl)
(ssadd enl rtn)
)
)
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
rtn
)
)
)
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)
(defun mxv ( m v )
(mapcar
'(lambda ( r )
(apply '+ (mapcar '* r v))
)
m
)
)
(defun mxm ( m n )
(mapcar
'(lambda ( r )
(mapcar '(lambda ( c ) (apply '+ (mapcar '* r c))) (apply 'mapcar (cons 'list n)))
)
m
)
)
;------------------------------------------------------------------------------------------------------------
(defun ent2ptlst ( ent / obj dist n lst p_lst prec)
(vl-load-com)
(if (= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
(cond
( (member (cdr (assoc 0 (entget ent))) '( "CIRCLE" "ELLIPSE" ))
(setq dist (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) 50 )
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
(vlax-get obj 'Normal)
)
lst
)
)
)
)
( T
(setq p_lst (vl-remove-if-not '(lambda (x) (or (= (car x) 10)(= (car x) 42))) (entget ent)))
(while p_lst
(setq lst (cons (append (cdr (assoc 10 p_lst)) (list (cdr (assoc 38 (entget ent))))) lst ))
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
dist
(/
(-
(if (cdaddr p_lst)
(vlax-curve-getDistAtPoint obj (trans (cdaddr p_lst) ent 0))
(vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
)
(vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0))
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0))
(* dist (setq n (1+ n)))
)
)
0
ent
)
lst
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
lst
)
(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
(setq dxf10
(list (apply 'min (mapcar 'car pt_lst))
(apply 'min (mapcar 'cadr pt_lst))
(caddar pt_lst)
)
)
(setq
max_dist
(float
(apply 'max
(mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
)
)
)
(setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
(setq dxf14
(mapcar
'(lambda (p)
(mapcar '/
(mapcar '- p cen)
(list max_dist (- max_dist) 1.0)
)
)
pt_lst
)
)
(setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
(entmake
(append
(list
'(0 . "WIPEOUT")
'(100 . "AcDbEntity")
'(100 . "AcDbWipeout")
'(90 . 0)
(cons 10 (trans dxf10 nor 0))
(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
'(13 1.0 1.0 0.0)
'(70 . 7)
'(280 . 1)
'(71 . 2)
(cons 91 (length dxf14))
)
(mapcar '(lambda (p) (cons 14 p)) dxf14)
)
)
)
;; Getsel
(defun AT:GetSel ( meth msg fnc / ent good )
;; meth - selection method (entsel, nentsel, nentselp)
;; msg - message to display (nil for default)
;; fnc - optional function to apply to selected object
;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
;; Alan J. Thompson, 05.25.10
(setvar 'errno 0)
(while (not good)
(setq ent (meth (cond (msg)
("\nSelect sample object: ")
)
)
)
(cond
((vl-consp ent)
(setq good (if (or (not fnc) (fnc ent))
ent
(prompt "\n: Invalid object !\n")
)
)
)
((eq (type ent) 'STR) (setq good ent))
((setq good (eq 52 (getvar 'errno))) nil)
((eq 7 (getvar 'errno)) (setq good (prompt "\n: Missed ! Try again\n")))
)
)
)
(vl-load-com)
(princ "\n[WB] Wipeout by boundary loaded. Type WB to use.")
(princ "\nReshared on lisp.vn.")
(princ)Chỉnh sửa bởi bạn Le Tan Phuc và Qthang nhóm [AutoLISP hỗ trợ lisp cad]
Link tải (MediaFire)
---------------------------------------------------------------------------------------------
Mọi thông tin xin liên hệ Fanpage AutoLISP Thật là đơn giản!
Cảm ơn bạn đã theo dõi!
Không có nhận xét nào:
Đăng nhận xét