Request for custom lisp routine

accuratedd · ‎01-03-2020

I'm hoping to get some help to come up with a custom lisp routine that changes the components of a detail I would receive from an architect and explode the blocks and nested blocks all to my background layer "BY OTHERS". Here are the requirements:

- Select specific details and not the entire drawing

- All blocks and nested blocks at every level to be exploded.
- All lines, polylines, arcs, circles, etc. to change to the "BY OTHERS" layer.
- All hatch patterns to remain a hatch component and change to the "BY OTHERS" layer.
- All linetypes to retain their original linetype setting ( I would like to possibly address this in a future revision).
- After all of this is done, I would like to have all of these components to have a color and lineweight of "ByLayer"

and a linetype scale of 1 and run the Overkill command.

I don't know if this is allowed here but I would be willing to offer compensation for the completed routine since this seems like a lot of work and it will be used for my shop drawing practice.

Thanks, Jeff

marko_ribar · ‎01-03-2020

Untested, but it's a good start...

(defun LM:burst ( nst / *error* ss blss i ent el obj )

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

    (if (not (tblsearch "LAYER" "BY OTHERS"))
        (progn
            (vl-cmdf "_.-LAYER" "_M" "BY OTHERS")
            (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
        )
    )
    (LM:startundo (LM:acdoc))
    (setq ss (ssget "_:L" (list (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
    (setq blss (ssadd))
    (repeat (setq i (sslength ss))
        (if (and (= (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "INSERT") (/= 4 (logand 4 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget ent)))))))))
            (ssadd ent blss)
            (ssdel ent ss)
        )
    )
    (setq el (entlast))
    (LM:burstsel
        blss
        nst
    )
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
        (vla-put-layer (setq obj (vlax-ename->vla-object e)) "BY OTHERS")
        (vla-put-color obj "ByLayer")
        (vla-put-lineweight obj "ByLayer")
        (vla-put-linetypescale obj 1.0)
    )
    (while (setq el (entnext el))
        (ssadd el ss)
    )
    (vl-cmdf "_.-OVERKILL" ss "" "_O" 1e-4 "_I" "_A" "_P" "_Y" "")
    (LM:endundo (LM:acdoc)) (princ)
)

(defun LM:burstsel ( sel nst / idx )
    (if (= 'pickset (type sel))
        (repeat (setq idx (sslength sel))
            (LM:burstobject (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) nst)
        )
    )
)

(defun LM:burstobject ( obj nst / cmd col ent err lay lst qaf tmp liw lts )
    (if
        (and
            (= "AcDbBlockReference" (vla-get-objectname obj))
            (not (vlax-property-available-p obj 'path))
            (vlax-write-enabled-p  obj)
            (or (and (LM:usblock-p obj)
                     (not (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vlax-invoke (list obj 'explode)))))
                     (setq lst err)
                )
                (progn
                    (setq tmp (vla-copy obj)
                          ent (LM:entlast)
                          cmd (getvar 'cmdecho)
                          qaf (getvar 'qaflags)
                    )
                    (setvar 'cmdecho 0)
                    (setvar 'qaflags 0)
                    (vl-cmdf "_.explode" (vlax-vla-object->ename tmp))
                    (setvar 'qaflags qaf)
                    (setvar 'cmdecho cmd)
                    (while (setq ent (entnext ent))
                        (setq lst (cons (vlax-ename->vla-object ent) lst))
                    )
                    lst
                )
            )
        )
        (progn
            (setq lay "BY OTHERS"
                  col "ByLayer"
                  liw "ByLayer"
                  lts 1.0
            )
            (foreach att (vlax-invoke obj 'getattributes)
                (if (vlax-write-enabled-p att)
                    (progn
                        (if (= "0" (vla-get-layer att))
                            (vla-put-layer att lay)
                        )
                        (if (= acbyblock (vla-get-color att))
                            (vla-put-color att col)
                        )
                        (if (= "byblock" (strcase (vla-get-linetype att) t))
                            (vla-put-linetype att lin)
                        )
                    )
                )
                (if
                    (and
                        (= :vlax-false (vla-get-invisible att))
                        (= :vlax-true  (vla-get-visible   att))
                    )
                    (   (if (and (vlax-property-available-p att 'mtextattribute) (= :vlax-true (vla-get-mtextattribute att)))
                            LM:burst:matt2mtext 
                            LM:burst:att2text
                        )
                        (entget (vlax-vla-object->ename att))
                    )
                )
            )
            (foreach new lst
                (cond
                    (   (not (vlax-write-enabled-p new)))
                    (   (= :vlax-false (vla-get-visible new))
                        (vla-delete new)
                    )
                    (   t
                        (vla-put-layer new lay)
                        (vla-put-color new col)
                        (vla-put-lineweight new liw)
                        (vla-put-linetypescale new lts)
                        (if (= "AcDbAttributeDefinition" (vla-get-objectname new))
                            (progn
                                (if
                                    (and
                                        (= :vlax-true  (vla-get-constant  new))
                                        (= :vlax-false (vla-get-invisible new))
                                    )
                                    (   (if (and (vlax-property-available-p new 'mtextattribute) (= :vlax-true (vla-get-mtextattribute new)))
                                            LM:burst:matt2mtext 
                                            LM:burst:att2text
                                        )
                                        (entget (vlax-vla-object->ename new))
                                    )
                                )
                                (vla-delete new)
                            )
                            (if nst (LM:burstobject new nst))
                        )
                    )
                )
            )
            (vla-delete obj)
        )
    )
)

(defun LM:burst:removepairs ( itm lst )
    (vl-remove-if '(lambda ( x ) (member (car x) itm)) lst)
)

(defun LM:burst:remove1stpairs ( itm lst )
    (vl-remove-if '(lambda ( x ) (if (member (car x) itm) (progn (setq itm (vl-remove (car x) itm)) t))) lst)
)

(defun LM:burst:att2text ( enx )
    (entmakex
        (append '((0 . "TEXT"))
            (LM:burst:removepairs '(000 002 003 070 074 100 280 440)
                (subst (cons 73 (cdr (assoc 74 enx))) (assoc 74 enx) enx)
            )
        )
    )
)

(defun LM:burst:matt2mtext ( enx )
    (entmakex
        (append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
            (LM:burst:remove1stpairs
                (if (= "ATTDEF" (cdr (assoc 0 enx)))
                   '(001 003 007 010 040 041 050 071 072 073 210)
                   '(001 007 010 040 041 050 071 072 073 210)
                )
                (LM:burst:removepairs '(000 002 011 042 043 051 070 074 100 101 102 280 330 360 440) enx)
            )
            (list (assoc 011 (reverse enx)))
        )
    )
)

;; Uniformly Scaled Block  -  Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
    (if (vlax-property-available-p obj 'xeffectivescalefactor)
        (setq s "effectivescalefactor")
        (setq s "scalefactor")
    )
    (eval
        (list 'defun 'LM:usblock-p '( obj )
            (list 'and
                (list 'equal
                    (list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
                    (list 'abs (list 'vlax-get-property 'obj (strcat "y" s)))
                    1e-8
                )
                (list 'equal
                    (list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
                    (list 'abs (list 'vlax-get-property 'obj (strcat "z" s)))
                    1e-8
                )
            )
        )
    )
    (LM:usblock-p obj)
)

;; entlast  -  Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
    (setq ent (entlast))
    (while (setq tmp (entnext ent)) (setq ent tmp))
    ent
)

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

(defun c:process nil (LM:burst   t))
(prompt "\nInvoke with 'process'")
(vl-load-com)
(princ)

Marko Ribar, d.i.a. (graduated engineer of architecture)

accuratedd · ‎01-03-2020

Marko, thank you for the fast response but it doesn't work. Here is what I received after running it:

Select objects: Specify opposite corner: 549 found
Select objects:
Error: lisp value has no coercion to VARIANT with this type: "ByLayer"

It doesn't seem to get very far into the routine as no objects are modified. I have attached a sample detail for you to try it on if needed.

Thanks, Jeff

marko_ribar · ‎01-03-2020

Here, I've debugged it...

(defun LM:burst ( nst / *error* ss blss i ent el obj )

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

    (if (not (tblsearch "LAYER" "BY OTHERS"))
        (progn
            (vl-cmdf "_.-LAYER" "_M" "BY OTHERS")
            (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
        )
    )
    (LM:startundo (LM:acdoc))
    (setq ss (ssget "_:L" (list (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
    (setq blss (ssadd))
    (repeat (setq i (sslength ss))
        (if (and (= (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "INSERT") (/= 4 (logand 4 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget ent)))))))))
            (progn
                (ssadd ent blss)
                (ssdel ent ss)
            )
        )
    )
    (setq el (entlast))
    (LM:burstsel
        blss
        nst
    )
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
        (if (not (vlax-erased-p e))
           (progn
                (vla-put-layer (setq obj (vlax-ename->vla-object e)) "BY OTHERS")
                (vla-put-color obj 256)
                (vla-put-lineweight obj -1)
                (vla-put-linetypescale obj 1.0)
           )
       )
    )
    (while (setq el (entnext el))
        (ssadd el ss)
    )
    (vl-cmdf "_.-OVERKILL" ss "" "_O" 1e-4 "_I" "_A" "_P" "_Y" "")
    (LM:endundo (LM:acdoc)) (princ)
)

(defun LM:burstsel ( sel nst / idx )
    (if (= 'pickset (type sel))
        (repeat (setq idx (sslength sel))
            (LM:burstobject (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) nst)
        )
    )
)

(defun LM:burstobject ( obj nst / cmd col ent err lay lst qaf tmp liw lts )
    (if
        (and
            (= "AcDbBlockReference" (vla-get-objectname obj))
            (not (vlax-property-available-p obj 'path))
            (vlax-write-enabled-p  obj)
            (or (and (LM:usblock-p obj)
                     (not (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vlax-invoke (list obj 'explode)))))
                     (setq lst err)
                )
                (progn
                    (setq tmp (vla-copy obj)
                          ent (LM:entlast)
                          cmd (getvar 'cmdecho)
                          qaf (getvar 'qaflags)
                    )
                    (setvar 'cmdecho 0)
                    (setvar 'qaflags 0)
                    (vl-cmdf "_.EXPLODE" (vlax-vla-object->ename tmp))
                    (setvar 'qaflags qaf)
                    (setvar 'cmdecho cmd)
                    (while (setq ent (entnext ent))
                        (setq lst (cons (vlax-ename->vla-object ent) lst))
                    )
                    lst
                )
            )
        )
        (progn
            (setq lay "BY OTHERS"
                  col 256
                  liw -1
                  lts 1.0
            )
            (foreach att (vlax-invoke obj 'getattributes)
                (if (vlax-write-enabled-p att)
                    (progn
                        (if (= "0" (vla-get-layer att))
                            (vla-put-layer att lay)
                        )
                        (if (= acbyblock (vla-get-color att))
                            (vla-put-color att col)
                        )
                        (if (= "byblock" (strcase (vla-get-linetype att) t))
                            (vla-put-linetype att lin)
                        )
                    )
                )
                (if
                    (and
                        (= :vlax-false (vla-get-invisible att))
                        (= :vlax-true  (vla-get-visible   att))
                    )
                    (   (if (and (vlax-property-available-p att 'mtextattribute) (= :vlax-true (vla-get-mtextattribute att)))
                            LM:burst:matt2mtext 
                            LM:burst:att2text
                        )
                        (entget (vlax-vla-object->ename att))
                    )
                )
            )
            (foreach new lst
                (cond
                    (   (not (vlax-write-enabled-p new)))
                    (   (= :vlax-false (vla-get-visible new))
                        (vla-delete new)
                    )
                    (   t
                        (vla-put-layer new lay)
                        (vla-put-color new col)
                        (vla-put-lineweight new liw)
                        (vla-put-linetypescale new lts)
                        (if (= "AcDbAttributeDefinition" (vla-get-objectname new))
                            (progn
                                (if
                                    (and
                                        (= :vlax-true  (vla-get-constant  new))
                                        (= :vlax-false (vla-get-invisible new))
                                    )
                                    (   (if (and (vlax-property-available-p new 'mtextattribute) (= :vlax-true (vla-get-mtextattribute new)))
                                            LM:burst:matt2mtext 
                                            LM:burst:att2text
                                        )
                                        (entget (vlax-vla-object->ename new))
                                    )
                                )
                                (vla-delete new)
                            )
                            (if nst (LM:burstobject new nst))
                        )
                    )
                )
            )
            (vla-delete obj)
        )
    )
)

(defun LM:burst:removepairs ( itm lst )
    (vl-remove-if '(lambda ( x ) (member (car x) itm)) lst)
)

(defun LM:burst:remove1stpairs ( itm lst )
    (vl-remove-if '(lambda ( x ) (if (member (car x) itm) (progn (setq itm (vl-remove (car x) itm)) t))) lst)
)

(defun LM:burst:att2text ( enx )
    (entmakex
        (append '((0 . "TEXT"))
            (LM:burst:removepairs '(000 002 003 070 074 100 280 440)
                (subst (cons 73 (cdr (assoc 74 enx))) (assoc 74 enx) enx)
            )
        )
    )
)

(defun LM:burst:matt2mtext ( enx )
    (entmakex
        (append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
            (LM:burst:remove1stpairs
                (if (= "ATTDEF" (cdr (assoc 0 enx)))
                   '(001 003 007 010 040 041 050 071 072 073 210)
                   '(001 007 010 040 041 050 071 072 073 210)
                )
                (LM:burst:removepairs '(000 002 011 042 043 051 070 074 100 101 102 280 330 360 440) enx)
            )
            (list (assoc 011 (reverse enx)))
        )
    )
)

;; Uniformly Scaled Block  -  Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
    (if (vlax-property-available-p obj 'xeffectivescalefactor)
        (setq s "effectivescalefactor")
        (setq s "scalefactor")
    )
    (eval
        (list 'defun 'LM:usblock-p '( obj )
            (list 'and
                (list 'equal
                    (list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
                    (list 'abs (list 'vlax-get-property 'obj (strcat "y" s)))
                    1e-8
                )
                (list 'equal
                    (list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
                    (list 'abs (list 'vlax-get-property 'obj (strcat "z" s)))
                    1e-8
                )
            )
        )
    )
    (LM:usblock-p obj)
)

;; entlast  -  Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
    (setq ent (entlast))
    (while (setq tmp (entnext ent)) (setq ent tmp))
    ent
)

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

(defun c:process nil (LM:burst   t))
(prompt "\nInvoke with 'process'")
(vl-load-com)
(princ)

Marko Ribar, d.i.a. (graduated engineer of architecture)

accuratedd · ‎01-03-2020

Marko, that's perfect. Thank you so much!

Community

Request for custom lisp routine

Request for custom lisp routine

Request for custom lisp routine