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 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)
2 Thêm class CBC_.lsp
Lưu mã sau dưới dạng tệp tin CBC_.lsp
Code:
;; EllipseToPolyline (gile)
;; Retourne une polyline (vla-object) qui est une approximation de l'ellipse (ou de l'arc elliptique)
;; L'ellipse source est conservée ou supprimée en fonction de la valeur de DELOBJ
;;
;; Argument : une ellipse (vla-object)
(defun EllipseToPolyline (el / doc cl norm cen elv
pt0 pt1 pt2 pt3 pt4 ac0 ac4
a04 a02 a24 bsc1 bsc2 bsc3 bsc4
plst blst spt spa fspa srat ept
epa fepa erat n
)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
spc (if (= 1 (getvar 'cvport))
(vla-get-PaperSpace doc)
(vla-get-ModelSpace doc)
)
cl (and (= (vla-get-StartAngle el) 0.0)
(= (vla-get-EndAngle el) (* 2 pi))
)
norm (vlax-get el 'Normal)
cen (trans (vlax-get el 'Center) 0 norm)
elv (caddr cen)
cen (3dTo2dPt cen)
pt0 (mapcar '+ (trans (vlax-get el 'MajorAxis) 0 norm) cen)
ac0 (angle cen pt0)
pt4 (mapcar '+ cen (trans (vlax-get el 'MinorAxis) 0 norm))
pt2 (3dTo2dPt
(trans (vlax-curve-getPointAtparam el (/ pi 4.)) 0 norm)
)
ac4 (angle cen pt4)
a04 (angle pt0 pt4)
a02 (angle pt0 pt2)
a24 (angle pt2 pt4)
bsc1 (/ (ang<2pi (- a02 ac4)) 2.)
bsc2 (/ (ang<2pi (- a04 a02)) 2.)
bsc3 (/ (ang<2pi (- a24 a04)) 2.)
bsc4 (/ (ang<2pi (- (+ ac0 pi) a24)) 2.)
pt1 (inters pt0
(polar pt0 (+ ac0 (/ pi 2.) bsc1) 1.)
pt2
(polar pt2 (+ a02 bsc2) 1.)
nil
)
pt3 (inters pt2
(polar pt2 (+ a04 bsc3) 1.)
pt4
(polar pt4 (+ a24 bsc4) 1.)
nil
)
plst (list pt4 pt3 pt2 pt1 pt0)
blst (mapcar '(lambda (B) (tan (/ b 2.)))
(list bsc4 bsc3 bsc2 bsc1)
)
)
(repeat 2
(foreach b blst
(setq blst (cons b blst))
)
)
(foreach p (cdr plst)
(setq ang (angle cen p)
plst (cons
(polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p))
plst
)
)
)
(foreach p (cdr plst)
(setq ang (angle cen p)
plst (cons
(polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p))
plst
)
)
)
(setq pl
(vlax-invoke
spc
'AddLightWeightPolyline
(apply 'append
(setq plst
(reverse (if cl
(cdr plst)
plst
)
)
)
)
)
)
(vlax-put pl 'Normal norm)
(vla-put-Elevation pl elv)
(mapcar '(lambda (i v) (vla-SetBulge pl i v))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
blst
)
(if cl
(vla-put-Closed pl :vlax-true)
(progn
(setq spt (vlax-curve-getClosestPointTo pl (vlax-get el 'Startpoint))
spa (vlax-curve-getParamAtPoint pl spt)
fspa (fix spa)
ept (vlax-curve-getClosestPointTo pl (vlax-get el 'Endpoint))
epa (vlax-curve-getParamAtPoint pl ept)
fepa (fix epa)
n 0
)
(cond
((equal spt (trans pt0 norm 0) 1e-9)
(if (= epa fepa)
(setq plst (sublist plst 0 (1+ fepa))
blst (sublist blst 0 (1+ fepa))
)
(setq erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (1+ fepa))
(vlax-curve-getDistAtParam pl fepa)
)
)
plst (append (sublist plst 0 (1+ fepa))
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append (sublist blst 0 (1+ fepa))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
((equal ept (trans pt0 norm 0) 1e-9)
(if (= spa fspa)
(setq plst (sublist plst fspa nil)
blst (sublist blst fspa nil)
)
(setq srat (/ (- (vlax-curve-getDistAtParam pl (1+ fspa))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (1+ fspa))
(vlax-curve-getDistAtParam pl fspa)
)
)
plst (cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
blst (cons (k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
)
)
(T
(setq srat (/ (- (vlax-curve-getDistAtParam pl (1+ fspa))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (1+ fspa))
(vlax-curve-getDistAtParam pl fspa)
)
)
erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (1+ fepa))
(vlax-curve-getDistAtParam pl fepa)
)
)
)
(if (< epa spa)
(setq plst (append
(if (= spa fspa)
(sublist plst fspa nil)
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
)
(cdr (sublist plst 0 (1+ fepa)))
(if (/= epa fepa)
(list (3dTo2dPt (trans ept 0 norm)))
)
)
blst (append
(if (= spa fspa)
(sublist blst fspa nil)
(cons
(k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
(sublist blst 0 fepa)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
(setq plst (append
(if (= spa fspa)
(sublist plst fspa (1+ (- fepa fspa)))
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) (- fepa fspa))
)
)
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append
(if (= spa fspa)
(sublist blst fspa (- fepa fspa))
(cons
(k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) (- fepa fspa))
)
)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
)
)
(vla-delete pl)
(setq pl (vlax-invoke
spc
'AddLightWeightPolyline
(apply 'append plst)
)
)
(vlax-put pl 'Normal norm)
(vla-put-Elevation pl elv)
(foreach b blst
(vla-SetBulge pl n B)
(setq n (1+ n))
)
)
)
(or (zerop (getvar 'delobj)) (vla-delete el))
pl
)
;; Ang<2pi
;; Retourne l'angle, à 2*k*pi près, compris entre 0 et 2*pi
(defun ang<2pi (ang)
(if (and (<= 0 ang) (< ang (* 2 pi)))
ang
(ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
)
)
;; 3dTo2dPt
;; Retourne le point 2d (x y) d'un point 3d (x y z)
(defun 3dTo2dPt (pt) (list (car pt) (cadr pt)))
;; Tan
;; Retourne la tangent de l'angle
(defun tan (a) (/ (sin a) (cos a)))
;;; SUBLIST Retourne une sous-liste
;;;
;;; Arguments
;;; lst : une liste
;;; start : l'index de départ de la sous liste (premier élément = 0)
;;; leng : la longueur (nombre d'éléments) de la sous-liste (ou nil)
(defun sublist (lst start leng / n r)
(if (or (not leng) (< (- (length lst) start) leng))
(setq leng (- (length lst) start))
)
(setq n (+ start leng))
(while (< start n)
(setq r (cons (nth (setq n (1- n)) lst) r))
)
)
;; K*BULGE
;; Retourne le bulge proportionnel au bulge de référence
;; Arguments :
;; b : le bulge
;; k : le rapport de proportion (entre les angles ou les longueurs d'arcs)
(defun k*bulge (b k / a)
(setq a (atan B))
(/ (sin (* k a)) (cos (* k a)))
)
(defun c:thongtin ()
(alert
"Nguoi viet:Lam Nguyen Trong-SDT-Zalo:0377390879-Email:trongag113@gmail.com-fb:www.facebook.com/trong.lam.7161"
)
(alert
"Ham EllipseToPolyline chuyen ellipse thanh polyline duoc lay tu dien dan autodesk.XIn cam on cac tac gia"
)
)
(c:thongtin)
;;main
(defun c:cbc (/ ss)
(princ "\nChon cac duong tron hoac ellipse")
(setq ss (ssget '((0 . "CIRCLE,ELLIPSE,LWPOLYLINE"))))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i))
(setq kieudt (cdr (assoc 0 (entget name))))
(if (= kieudt "ELLIPSE")
(progn
(EllipseToPolyline (vlax-ename->vla-object name))
(setq el0 (entlast))
(command "pedit" "" el0 "D" "")
;;(command "erase" el0"")
)
;; dong progn
)
;; dong if
(if (= kieudt "LWPOLYLINE")
(progn
;;(command "WIPEOUT" "P" name "y")
;;(command "erase" name "")
(setq el0 name)
)
(progn
(setq pt (cdr (assoc 10 (entget name))))
(setq bankinh (cdr (assoc 40 (entget name))))
(command "POLYGON" 360 pt "I" bankinh)
(setq el0 (entlast))
)
;;dong progn
)
;;dong if
(command "WIPEOUT" "P" el0 "y")
(command "erase" name "")
(setq i (1+ i))
)
)
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