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 class 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 "\n✅ Wipeout was added to block.")
)
(princ "\n⚠️ Invalid block selected.")
)
)
)
;; Hỏi có xóa wipeout không
;(initget "Yes No")
;(if (= (getkword "\nDelete wipeout? [Yes/No] <No>: ") "Yes")
;(entdel wipe)
;)
)
(princ "\n⚠️ Khô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))
)
)
)
(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)
---------------------------------------------------------------------------------------------
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