(defun c:TT (/ *error* arcbugle acdoc space
ss n reg norm expl olst
blst dlst plst tlst blg pline
)
(vl-load-com)
;;;***************************************************************;;;
(defun *error* (msg)
(if (/= msg "Function cancelled")
(princ (strcat "\nError: " msg))
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(princ)
)
;;;***************************************************************;;;
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
space (if (= 1 (getvar "CVPORT"))
(vla-get-PaperSpace acdoc)
(vla-get-ModelSpace acdoc)
)
)
(if (ssget '((0 . "REGION")))
(progn
(vla-StartUndoMark acdoc)
(vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))
(setq norm (vlax-get reg 'Normal)
expl (vlax-invoke reg 'Explode)
)
(if (vl-every '(lambda (x)
(or
(= (vla-get-ObjectName x) "AcDbLine")
(= (vla-get-ObjectName x) "AcDbArc")
)
)
expl
)
(progn
(vla-delete reg)
(setq olst (mapcar '(lambda (x)
(list x
(vlax-get x 'StartPoint)
(vlax-get x 'EndPoint)
)
)
expl
)
)
(while olst
(setq blst nil)
(if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
(setq blst (list (cons 0 (arcbulge (caar olst)))))
)
(setq plst (cdar olst)
dlst (list (caar olst))
olst (cdr olst)
)
(while
(setq
tlst
(vl-member-if
'(lambda (x)
(or (equal (last plst) (cadr x) 1e-9)
(equal (last plst) (caddr x) 1e-9)
)
)
olst
)
)
(if (equal (last plst) (caddar tlst) 1e-9)
(setq blg -1)
(setq blg 1)
)
(if
(= (vla-get-ObjectName (caar tlst)) "AcDbArc")
(setq
blst
(cons (cons (1- (length plst))
(* blg (arcbulge (caar tlst)))
)
blst
)
)
)
(setq plst (append plst
(if (minusp blg)
(list (cadar tlst))
(list (caddar tlst))
)
)
dlst (cons (caar tlst) dlst)
olst (vl-remove (car tlst) olst)
)
)
(setq pline
(vlax-invoke
Space
'addLightWeightPolyline
(apply 'append
(mapcar '(lambda (x)
(setq x (trans x 0 Norm))
(list (car x) (cadr x))
)
(reverse (cdr (reverse plst)))
)
)
)
)
(vla-put-Closed pline :vlax-true)
(mapcar
'(lambda (x) (vla-setBulge pline (car x) (cdr x)))
blst
)
(vla-put-Elevation
pline
(caddr (trans (car plst) 0 Norm))
)
(vla-put-Normal pline (vlax-3d-point Norm))
(mapcar 'vla-delete dlst)
)
)
(mapcar 'vla-delete expl)
)
)
(vla-delete ss)
(vla-EndUndoMark acdoc)
)
)
(princ)
)
6666666666666
不错，来学习一下