Union of closed plines and joining lines and keep all XData from first selected pline.

[frisbee]

Hello all,

From the genius Lee Mac are a couple of programs, one will draw an outline pline from selected entities and the other will copy all XData from one object to another.

I called my function, DelCloset and it basically is meant to combine closet rooms with their adjoining parent room and keep all XData from the selected parent room's pline. To do this, the user needs to select the parent room pline, and then select any plines to be combined as well as the jamb lines in the closet doorway. FYI, there could be as many as 1500+ closets that will need to be combined with their parent room.

I am a vanilla lisp programmer and with VLisp I am more of a hack. I combined the programs myself and got it working, but if there is no XData associated with the parent room, the program crashes.

Additionally, I welcome fixing the (command "select") method I used to be proper VLisp.

Below is the code from Lee Mac as well as my hacked version of DelCloset

;; 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 c:outline ( / *error* idx sel )
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (if (setq sel (ssget))
        (progn
            (LM:startundo (LM:acdoc))
            (LM:outline sel)
            (initget "Yes No")
            (if (/= "No" (getkword "\nErase original objects? [Yes/No] <Yes>: "))
                (repeat  (setq idx (sslength sel))
                    (entdel (ssname sel (setq idx (1- idx))))
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; 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
        )
    )
)

;; 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))
    )
)

;; 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)

;;==========================

(defun c:CpyX (/ ent obj ss sel)
(vl-load-com)

(while
(progn
(setq ent (car (entsel "\nSelect Object: ")))
(cond ((not ent) (princ "\n** Nothing Selected **"))
((progn
(vla-getXData
(setq Obj (vlax-ename->vla-object ent)) "" 'typ 'val)
(or (not typ) (not val)))
(princ "\n** No XData Found **")))))

(if (setq ss (ssget))
(progn
(vlax-for Obj (setq sel (vla-get-ActiveSelectionSet
(vla-get-ActiveDocument
(vlax-get-acad-object))))
(vla-SetXdata Obj typ val))
(vla-delete sel)))

(princ))

;;==========================

(defun c:DelCloset (/ ss typ val dss sel cur_clayer)
(vl-load-com)

(setq cur_clayer (getvar "clayer"))
(prompt "\nSelect Parent Room Polyline...")
(while
(progn
(setq ss (ssget "_:S:E" '((0 . "*POLYLINE"))))
(cond ((not ss)
(princ "\n** Nothing Selected **"))
((progn

  (setvar "clayer" (cdr (assoc 8 (entget (ssname ss 0)))) )
  (redraw (ssname ss 0) 3)
  (vla-getXData
  (setq Obj
  (vlax-ename->vla-object
  (ssname ss 0))) "" 'typ 'val)
  (or (not typ) (not val)))
  (princ "\n** No XData Found **")))))

;; Partial code from outline program above

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    ) 

    (prompt "\nSelect polylines and lines to be combined...")
    (if (setq sel (ssget))
        (progn
            (LM:startundo (LM:acdoc))
            (setq ss1 (LM:outline sel))
            
                (repeat  (setq idx (sslength sel))
                    (entdel (ssname sel (setq idx (1- idx))))
                )

            (LM:endundo (LM:acdoc))
        )
    )

 (command "select" ss1 "") ;needs proper coding?

 (if ss1 
 ;(if (setq dss (ssget '((0 . "*POLYLINE"))))
  (progn
    (vlax-for Obj (setq sel (vla-get-ActiveSelectionSet
    (vla-get-ActiveDocument
    (vlax-get-acad-object))))
    (vla-SetXdata Obj typ val)
    )
    (vla-delete sel)
  )
 )
 (redraw (ssname ss 0) 4)
 (setvar "clayer" cur_clayer)
 (princ)

); end defun

(princ)

[BIG-AL]

Look at these two lines in your code

(princ "\n** No XData Found **")))))

(vla-SetXdata Obj typ val)

The 1st says there is no xdata but you do nothing
The second says do the xdata bit but as there is nothing it fails.
So two choices make dummy xdata value or the simpler wrap the setxdata in a if typ = NIL then skip not tested.

(if (/= typ nil) (vla-SetXdata Obj typ val))