;;; ---------------------------------------------------------------------------
;;; DeepBurst.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Bursts blocks through EVERY level of nesting in one pass, converting
;;; attributes to text as it goes.
;;;
;;; The Express Tools BURST command explodes one level and converts that level's
;;; attributes. Blocks nested inside then have to be burst again, and again, as
;;; many times as the nesting goes deep. This does the whole tree in a single
;;; operation.
;;;
;;; IT ALSO FIXES BURST'S WORST HABIT
;;; Express BURST reveals INVISIBLE attributes - fields the block author
;;; deliberately hid, which suddenly appear as text all over the drawing. This
;;; routine checks each attribute's invisible flag and discards hidden ones
;;; rather than converting them, so what you see after bursting is what you saw
;;; before.
;;;
;;; PROPERTIES ARE RESOLVED CORRECTLY
;;; Objects inside a block drawn on layer 0, or with BYBLOCK colour or
;;; linetype, inherit those properties from the block reference. Once the block
;;; is gone there is nothing to inherit from, so before deleting the reference
;;; its layer, colour and linetype are pushed onto any child that was relying
;;; on them. Without this, bursting silently changes the appearance of the
;;; drawing.
;;;
;;; NON-UNIFORMLY SCALED BLOCKS
;;; The ActiveX Explode method refuses a block scaled differently in X, Y and Z.
;;; Those are handled by falling back to the EXPLODE command on a temporary
;;; copy, with QAFLAGS cleared so the command does not prompt.
;;;
;;; XREFS ARE EXCLUDED
;;; The selection filter builds a list of every xref-dependent block definition
;;; and excludes them, since an xref cannot be exploded.
;;;
;;;   DEEPBURST  - burst blocks through all nesting levels
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; DeepBurst:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun DeepBurst:Doc nil
    (eval (list 'defun 'DeepBurst:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (DeepBurst:Doc)
)

;; ---------------------------------------------------------------------------
;; DeepBurst:UniformlyScaled
;; ---------------------------------------------------------------------------
;; True if the block reference is scaled equally in X, Y and Z.
;;
;; Older AutoCAD versions expose this as ScaleFactor, newer ones as
;; EffectiveScaleFactor. The property name is resolved once and this function
;; then replaces itself with a version that reads it directly.
;; ---------------------------------------------------------------------------
(defun DeepBurst:UniformlyScaled ( obj / prop )
    (if (vlax-property-available-p obj 'xeffectivescalefactor)
        (setq prop "effectivescalefactor")
        (setq prop "scalefactor")
    )
    (eval
        (list 'defun 'DeepBurst:UniformlyScaled '( obj )
            (list 'and
                (list 'equal
                      (list 'vlax-get-property 'obj (strcat "x" prop))
                      (list 'vlax-get-property 'obj (strcat "y" prop))
                      1e-8
                )
                (list 'equal
                      (list 'vlax-get-property 'obj (strcat "x" prop))
                      (list 'vlax-get-property 'obj (strcat "z" prop))
                      1e-8
                )
            )
        )
    )
    (DeepBurst:UniformlyScaled obj)
)

;; ---------------------------------------------------------------------------
;; DeepBurst:LastEntity
;; ---------------------------------------------------------------------------
;; Returns the genuinely last object in the database, including sub-entities.
;;
;; entlast alone stops at the last top-level entity, which is not sufficient
;; when the newest object is an attribute or a polyline vertex - both of which
;; are sub-entities that entnext will keep walking into.
;; ---------------------------------------------------------------------------
(defun DeepBurst:LastEntity ( / ent tmp )
    (setq ent (entlast))
    (while (setq tmp (entnext ent)) (setq ent tmp))
    ent
)

;; ---------------------------------------------------------------------------
;; DXF-pair filtering helpers, used when converting attributes to text.
;; ---------------------------------------------------------------------------

;; Removes EVERY pair whose group code is in the list.
(defun DeepBurst:RemovePairs ( codes lst )
    (vl-remove-if (function (lambda ( x ) (member (car x) codes))) lst)
)

;; Removes only the FIRST occurrence of each listed group code. Needed because
;; MText carries several group 10 and 40 entries with different meanings, and
;; only the leading one is the attribute's own.
(defun DeepBurst:RemoveFirstPairs ( codes lst )
    (vl-remove-if
        (function
            (lambda ( x )
                (if (member (car x) codes)
                    (progn (setq codes (vl-remove (car x) codes)) t)
                )
            )
        )
        lst
    )
)

;; ---------------------------------------------------------------------------
;; DeepBurst:AttToText
;; ---------------------------------------------------------------------------
;; Creates a TEXT object from a single-line attribute's data.
;;
;; The stripped groups are those specific to attributes and meaningless on text:
;; 0 type, 2 tag, 70 flags, 74 vertical justification, 100 subclass markers,
;; 280 lock flag.
;;
;; Group 74 is substituted into group 73 first, because vertical justification
;; is stored as 74 on an attribute but as 73 on text. Miss that and every
;; converted attribute jumps vertically.
;; ---------------------------------------------------------------------------
(defun DeepBurst:AttToText ( enx )
    (entmakex
        (append '((0 . "TEXT"))
            (DeepBurst:RemovePairs '(000 002 070 074 100 280)
                (subst (cons 73 (cdr (assoc 74 enx))) (assoc 74 enx) enx)
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; DeepBurst:MAttToMText
;; ---------------------------------------------------------------------------
;; Creates an MTEXT object from a multi-line attribute's data.
;;
;; Two passes are needed. The first strips groups that have no meaning on MText
;; at all. The second removes only the FIRST instance of the groups that appear
;; more than once with different meanings - the attribute's own copies, leaving
;; the MText content's copies intact.
;; ---------------------------------------------------------------------------
(defun DeepBurst:MAttToMText ( enx )
    (entmakex
        (append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
            (DeepBurst:RemoveFirstPairs '(001 007 010 011 040 041 050 071 072 073 210)
                (DeepBurst:RemovePairs  '(000 002 042 043 051 070 074 100 101 102 280 330 360)
                                        enx
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; DeepBurst:Burst
;; ---------------------------------------------------------------------------
;; Bursts one block reference and everything nested within it.
;;
;; This is the core, and it is recursive: after exploding, every child that is
;; itself a block reference is passed straight back into this function, so the
;; whole tree unwinds however deep it goes.
;;
;; It takes a single VLA block reference, so it can also be called directly
;; from your own routines.
;;
;; obj - [vla-object] the block reference to burst
;; ---------------------------------------------------------------------------
(defun DeepBurst:Burst ( obj / cmd col ent lay lin lst qaf tmp )
    (if
        (and
            (= "AcDbBlockReference" (vla-get-objectname obj))
            (vlax-write-enabled-p obj)
            (or
                ;; Preferred path: uniformly scaled blocks explode via ActiveX,
                ;; which returns the new objects directly and is much faster.
                (and (DeepBurst:UniformlyScaled obj)
                     (not (vl-catch-all-error-p
                              (setq lst (vl-catch-all-apply 'vlax-invoke (list obj 'explode)))
                          )
                     )
                )
                ;; Fallback for non-uniform scaling: explode a temporary copy
                ;; with the command, then collect everything created after it.
                (progn
                    (setq tmp (vla-copy obj)
                          ent (DeepBurst:LastEntity)
                          cmd (getvar 'cmdecho)
                          qaf (getvar 'qaflags)
                    )
                    (setvar 'cmdecho 0)
                    ;; QAFLAGS cleared so EXPLODE does not raise its own prompts.
                    (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
            ;; The properties children may be inheriting from this reference.
            (setq lay (vla-get-layer    obj)
                  col (vla-get-color    obj)
                  lin (vla-get-linetype obj)
            )

            ;; ---------------------------------------------------------------
            ;; Attributes: resolve inherited properties, then convert visible
            ;; ones to text. Invisible ones are simply not converted, which is
            ;; the fix for Express BURST's habit of revealing hidden data.
            ;; ---------------------------------------------------------------
            (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 (= :vlax-false (vla-get-invisible att))
                    (   (if (and (vlax-property-available-p att 'mtextattribute)
                                 (= :vlax-true (vla-get-mtextattribute att))
                            )
                            DeepBurst:MAttToMText
                            DeepBurst:AttToText
                        )
                        (entget (vlax-vla-object->ename att))
                    )
                )
            )

            ;; ---------------------------------------------------------------
            ;; Exploded children: attribute DEFINITIONS are discarded - they
            ;; are templates belonging to the block, not visible content, and
            ;; leaving them would litter the drawing with tag names. Everything
            ;; else has its inherited properties resolved and, if it is itself
            ;; a block, is burst in turn.
            ;; ---------------------------------------------------------------
            (foreach new lst
                (if (vlax-write-enabled-p new)
                    (if (= "AcDbAttributeDefinition" (vla-get-objectname new))
                        (vla-delete new)
                        (progn
                            (if (= "0" (vla-get-layer new))                     (vla-put-layer    new lay))
                            (if (= acbyblock (vla-get-color new))               (vla-put-color    new col))
                            (if (= "byblock" (strcase (vla-get-linetype new) t)) (vla-put-linetype new lin))
                            (DeepBurst:Burst new)
                        )
                    )
                )
            )

            (vla-delete obj)
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; DeepBurst:XrefFilter
;; ---------------------------------------------------------------------------
;; Returns a filter clause excluding every xref-dependent block definition, or
;; nil if the drawing contains none.
;;
;; Bit 4 of a block table record's DXF 70 marks it as an xref. The names are
;; joined into one comma-separated wildcard string wrapped in NOT.
;; ---------------------------------------------------------------------------
(defun DeepBurst:XrefFilter ( / def lst )
    (while (setq def (tblnext "block" (null def)))
        (if (= 4 (logand 4 (cdr (assoc 70 def))))
            (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))
        )
    )
    (if lst
        (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))
    )
)

;; ---------------------------------------------------------------------------
;; c:DEEPBURST  -  main routine
;; ---------------------------------------------------------------------------
(defun c:DEEPBURST ( / *error* vars vals sel idx count )

    ;; NOMUTT is suppressed around the selection so the custom prompt is the
    ;; only thing shown, and restored to its captured value afterwards - the
    ;; original reset it to a hard-coded 0.
    (setq vars '("CMDECHO" "NOMUTT" "QAFLAGS")
          vals (mapcar 'getvar vars)
    )

    (defun DeepBurst:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (DeepBurst:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** DEEPBURST error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
    ;; unless the routine says up front that it will use one. Restore does,
    ;; to close this undo group. The declaring call is absent on older
    ;; releases, so it is wrapped rather than tested for.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (princ "\nSelect blocks to burst: ")
    (setvar 'nomutt 1)
    (setq sel
        (vl-catch-all-apply 'ssget
            (list "_:L"
                (append '((0 . "INSERT"))
                        (DeepBurst:XrefFilter)
                        (if (= 1 (getvar 'cvport))
                            (list (cons 410 (getvar 'ctab)))
                           '((410 . "Model"))
                        )
                )
            )
        )
    )
    (setvar 'nomutt (cadr vals))

    (if (and sel (not (vl-catch-all-error-p sel)))
        (progn
            (setq count (sslength sel))
            (repeat (setq idx count)
                (DeepBurst:Burst
                    (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                )
            )
            (princ (strcat "\n" (itoa count)
                           " block" (if (= 1 count) "" "s")
                           " burst through all nesting levels."
                   )
            )
        )
        (princ "\nNothing selected.")
    )

    (DeepBurst:Restore)
    (princ)
)

(princ)