|
;Find and create polylines from selected objects
;Stefan M. v1.01 07.03.2014
;updated - v1.02 16.10.2018
(defun c:test ( / *error* break_object l2p ms ss i lst segments pa dr aa ce reg ea)
(or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
(setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
(vla-startundomark acDoc)
(setq pa (getvar 'peditaccept)
dr (getvar 'draworderctl)
ce (getvar 'cmdecho)
aa 0.00
)
(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(foreach x (append segments lst) (vl-catch-all-apply 'vla-delete (list x)))
(setvar 'peditaccept pa)
(setvar 'draworderctl dr)
(setvar 'cmdecho ce)
(vla-endundomark acDoc)
(princ)
)
(defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
(defun break_object (e points / object_type start center end radius normal arc res)
(if points
(progn
(setq points
(vl-sort points
(function
(lambda (a b)
(<
(vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e a))
(vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e b))
)
)
)
)
)
(cond
((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
(setq start (vlax-curve-getstartpoint e))
(while points
(if (> (distance start (car points)) 1e-5)
(setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
)
(setq points (cdr points))
)
)
(T
(if
(eq object_type "AcDbArc")
(setq start (vlax-curve-getStartParam e))
(setq start (vlax-curve-getparamatpoint e (car points))
points (reverse (cons (car points) (reverse (cdr points))))
)
)
(setq center (vla-get-Center e)
radius (vla-get-Radius e)
normal (vla-get-Normal e)
)
(while points
(if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-5))
(progn
(setq arc (vla-AddArc ms center radius start end))
(vla-put-Normal arc normal)
(setq res (cons arc res))
)
)
(setq points (cdr points)
start end)
)
)
)
)
)
res
)
(if
(setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE"))))
(progn
(repeat (setq i (sslength ss))
(setq i (1- i)
e (ssname ss i)
e (vlax-ename->vla-object e)
)
(if
(eq (vla-get-ObjectName e) "AcDbPolyline")
(foreach x (vlax-invoke e 'Explode)
(setq lst (cons x lst))
)
(setq lst (cons (vla-copy e) lst))
)
)
(if
(and
(setq segments
(apply 'append
(mapcar
(function
(lambda (e / l)
(break_object e
(progn
(foreach other (vl-remove e lst)
(foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
(if
(equal x (vlax-curve-getclosestpointto e x) 1e-8)
(setq l (cons x l))
)
)
)
(if
(eq (vla-get-ObjectName e) "AcDbCircle")
l
(cons (vlax-curve-getendpoint e) l)
)
)
)
)
)
lst
)
)
)
(not
(vl-catch-all-error-p
(setq reg
(vl-catch-all-apply 'vlax-invoke (list ms 'AddRegion segments))
)
)
)
)
(progn
(setvar 'peditaccept 1)
(setvar 'draworderctl 0)
(setvar 'cmdecho 0)
(foreach x reg
(setq x (vlax-vla-object->ename x))
(command "_explode" x)
(command "_pedit" "_m" "_p" "" "_j" "" "")
(if (> (vlax-curve-getArea (entlast)) aa) (setq aa (vlax-curve-getArea (setq ea (entlast)))))
)
(entdel ea)
(setvar 'peditaccept pa)
(setvar 'draworderctl dr)
(setvar 'cmdecho ce)
)
(princ "\nValid region(s) not found")
)
)
)
(*error* nil)
(princ)
) |
|