;; Batch BPoly - Lee Mac
;; Generates polylines for every region formed by a selection of lines & polylines
;; Restricted to LWPolylines with linear segments only.
;; Region generation based on a method by Stefan M.
(defun c:bbpoly ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx )
(defun *error* ( msg )
(foreach obj rtn
(if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
(vla-delete obj)
)
)
(mapcar 'setvar var val)
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
(princ "\nCurrent layer locked.")
)
( (setq sel
(LM:ssget "\nSelect Lines & Polylines: "
(list
(list
'(-4 . "<OR")
'(0 . "LINE")
'(-4 . "<AND")
'(0 . "LWPOLYLINE")
'(-4 . "<NOT")
'(-4 . "<>")
'(42 . 0.0)
'(-4 . "NOT>")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
)
(setq spc
(vlax-get-property (LM:acdoc)
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(repeat (setq idx (sslength sel))
(if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
(setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
(setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
lst (append vtx lst)
)
)
)
(foreach pl1 lst
(setq pt1 (car pl1)
pt2 (cadr pl1)
)
(foreach pl2 lst
(if
(and
(not (equal pl1 pl2 1e-8))
(setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
(not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
)
(setq pl1 (cons int pl1))
)
)
(setq rtn
(append
(mapcar
(function
(lambda ( a b )
(vla-addline spc
(vlax-3D-point a)
(vlax-3D-point b)
)
)
)
(setq pl1
(vl-sort pl1
(function
(lambda ( a b )
(< (distance pt1 a) (distance pt1 b))
)
)
)
)
(cdr pl1)
)
rtn
)
)
)
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
tot 0.0
)
(mapcar 'setvar var '(0 1))
(foreach reg (vlax-invoke spc 'addregion rtn)
(setq ent (entlast))
(command "_.pedit" "_m")
(apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
(command "" "_j" "" "")
(if
(and
(not (eq ent (setq ent (entlast))))
(= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
)
(progn
(setq tmp (vlax-curve-getarea ent)
tot (+ tot tmp)
)
(if (< (car big) tmp)
(setq big (list tmp ent))
)
)
)
(vla-delete reg)
)
(if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
(entdel (cadr big))
)
(foreach obj rtn (vla-delete obj))
(mapcar 'setvar var val)
)
)
(LM:endundo (LM:acdoc))
(princ)
)
;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;; 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)
)
)
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)(vl-load-com) (princ)
