(vl-load-com)
;------------------------------------------------------------------------------------------------------------
;------------------------------------------------------------------------------------------------------------
(defun c:PLUnion ( / *error* adoc oVAR nVAR :AllNewSince
ss en i)
;-------
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(mapcar 'setvar nVAR oVAR)
(vla-endundomark adoc)
(princ))
;; Gilles Chanteau- 01/01/07
(defun :Region2Polyline (ss / arcbugle acdoc space
n reg norm expl olst blst dlst plst tlst blg pline)
(defun arcbulge (arc)
(/ (sin (/ (vla-get-TotalAngle arc) 4))
(cos (/ (vla-get-TotalAngle arc) 4))))
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
space (if (= 1 (getvar "CVPORT"))
(vla-get-PaperSpace acdoc)
(vla-get-ModelSpace acdoc)))
(if ss
(repeat (setq i (sslength ss))
(setq reg (vlax-ename->vla-object (ssname ss (setq i (1- i))))
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)))
)
)
;-------
(defun :AllNewSince (ent ss /)
(while (setq ent (entnext ent)) (if (entget ent) (ssadd ent ss))) ss)
;-------------------------------------------------------------------------------------------------------
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setq oVAR (mapcar 'getvar (setq nVAR '(CMDECHO OSMODE))))
(mapcar 'setvar nVAR '(0 0))
(if (and (princ "Polylines required, ")
(setq ss (ssget ":L" '((0 . "LWPOLYLINE"))))
(setq enlast (entlast))
)
(progn
(command "_.REGION" ss "")
(setq ss nil
ss (ssadd)
ss (:AllNewSince enlast ss)
sn (ssadd))
(command "_.UNION" ss "")
(repeat (setq i (sslength ss))
(if (and (setq en (ssname ss (setq i (1- i))))
(entget en))
(ssadd en sn)))
(if sn (:Region2Polyline sn))
))
(*error* "end")
)
