;;; ---------------------------------------------------------------------------
;;; BlockPurge.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Deletes every reference of a block - including nested ones - and then
;;; purges the definition.
;;;
;;; The standard PURGE command only removes definitions that are already
;;; unused. When a block is still inserted somewhere, PURGE simply refuses, and
;;; you are left hunting for the last stray reference - which may well be
;;; nested three blocks deep on a layout you have forgotten about.
;;;
;;; This does the whole job: erases every reference at every level of nesting,
;;; across every layout, then removes the definition.
;;;
;;; TWO WAYS TO CHOOSE A BLOCK
;;;   Pick one in the drawing, or
;;;   type N for a filtered list of every block defined in the drawing, from
;;;   which several can be selected at once.
;;;
;;; The list has a filter box: type part of a name and the list narrows.
;;;
;;; LOCKED LAYERS ARE HANDLED
;;; References on locked layers would refuse to be deleted, so locked layers
;;; are temporarily unlocked, the deletions performed, and the locks restored
;;; exactly as they were. Any layer that was NOT locked is left untouched.
;;;
;;; The routine reports which blocks it removed and which it could not - a
;;; block may survive because it is referenced by a dimension style, a
;;; multileader style or a table style rather than by any geometry.
;;;
;;; FOR BATCH USE
;;; BlockPurge:Delete takes a document object and a list of block names, and
;;; can be called from your own scripts. It works with ObjectDBX documents too,
;;; so it can process drawings without opening them.
;;;
;;;   BLOCKPURGE  - delete blocks and their definitions
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; ---------------------------------------------------------------------------
;; BlockPurge:BlockName
;; ---------------------------------------------------------------------------
;; Returns a block reference's EFFECTIVE name - the name the user knows it by.
;;
;; A dynamic block that has been altered from its default state is stored under
;; an anonymous name like "*U27"; without this, such references would not be
;; matched against the name the user selected.
;; ---------------------------------------------------------------------------
(defun BlockPurge:BlockName ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (defun BlockPurge:BlockName ( obj ) (vla-get-effectivename obj))
        (defun BlockPurge:BlockName ( obj ) (vla-get-name obj))
    )
    (BlockPurge:BlockName obj)
)

;; ---------------------------------------------------------------------------
;; BlockPurge:Try
;; ---------------------------------------------------------------------------
;; Applies a function to arguments and returns a non-nil result on success, nil
;; if it threw. Used to test whether a block exists and whether it can be
;; deleted, both of which raise rather than returning a status.
;; ---------------------------------------------------------------------------
(defun BlockPurge:Try ( fnc args / rtn )
    (if (not (vl-catch-all-error-p (setq rtn (vl-catch-all-apply fnc args))))
        (cond ( rtn ) ( t ))
    )
)

;; ---------------------------------------------------------------------------
;; BlockPurge:Delete
;; ---------------------------------------------------------------------------
;; Deletes all references of the named blocks from a document, then their
;; definitions. Returns the list of names successfully removed.
;;
;; Works on any document object, including one opened via ObjectDBX, so it can
;; be driven from a batch script across many drawings.
;;
;; The iteration is over the BLOCKS collection rather than over model space,
;; which is what reaches nested references: every block definition is itself a
;; container, so walking them all finds references at every level, including
;; those inside other blocks and on every layout.
;;
;; doc - [vla-object] document to operate on
;; lst - [list] block names, case insensitive
;; ---------------------------------------------------------------------------
(defun BlockPurge:Delete ( doc lst / blocks locked )

    (setq blocks (vla-get-blocks doc))

    ;; Reduce the request to blocks that actually exist in this document.
    (if (setq lst
            (mapcar 'strcase
                (vl-remove-if-not
                    (function (lambda ( blk ) (BlockPurge:Try 'vla-item (list blocks blk))))
                    lst
                )
            )
        )
        (progn
            ;; Unlock every locked layer, remembering which ones so the locks
            ;; can be put back exactly as found.
            (vlax-for lay (vla-get-layers doc)
                (if (= :vlax-true (vla-get-lock lay))
                    (progn
                        (setq locked (cons lay locked))
                        (vla-put-lock lay :vlax-false)
                    )
                )
            )

            ;; Erase every reference, wherever it is nested.
            (vlax-for def blocks
                (vlax-for obj def
                    (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
                             (member (strcase (BlockPurge:BlockName obj)) lst)
                        )
                        (vl-catch-all-apply 'vla-delete (list obj))
                    )
                )
            )

            ;; Now remove the definitions, keeping only those that went.
            (setq lst
                (vl-remove-if-not
                    (function
                        (lambda ( blk )
                            (BlockPurge:Try 'vla-delete (list (vla-item blocks blk)))
                        )
                    )
                    lst
                )
            )

            (foreach lay locked (vla-put-lock lay :vlax-true))
            lst
        )
    )
)

;; ---------------------------------------------------------------------------
;; BlockPurge:Run
;; ---------------------------------------------------------------------------
;; Deletes the named blocks from the active drawing and reports the outcome.
;; ---------------------------------------------------------------------------
(defun BlockPurge:Run ( del / done )
    ;; 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")
    (setq done (BlockPurge:Delete (BlockPurge:Doc) del))
    (vla-regen (BlockPurge:Doc) acallviewports)
    (foreach blk del
        (if (member (strcase blk) done)
            (princ (strcat "\n  + deleted block \"" blk "\""))
            (princ (strcat "\n  - could not delete \"" blk "\" (it may be used by a style)"))
        )
    )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (command "_.UNDO" "_End")
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
    )
    done
)

;; ---------------------------------------------------------------------------
;; BlockPurge:FilterListBox
;; ---------------------------------------------------------------------------
;; A multi-select list with a filter box above it. Returns the chosen strings,
;; or nil.
;;
;; The filter action is stored as a quoted expression converted to a string,
;; which is how a multi-line action can be attached to a tile. When the filter
;; text changes it rebuilds the list to only matching entries, and then works
;; out where the previously selected items have moved to in the shortened list
;; so the selection survives filtering.
;;
;; The dialog name "blockpurge" must match between the DCL text and new_dialog.
;;
;; msg - [str] dialog title
;; lst - [list] strings to offer
;; mtp - [boolean] T to allow multiple selection
;; ---------------------------------------------------------------------------
(defun BlockPurge:FilterListBox ( msg lst mtp / BlockPurge:AddList dch dcl des rtn sel tmp flt )

    (defun BlockPurge:AddList ( key lst )
        (start_list key)
        (foreach x lst (add_list x))
        (end_list)
        lst
    )

    (if (and
            (setq dcl (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open dcl "w"))
            (write-line
                (strcat
                    "blockpurge : dialog { label = \"" msg "\"; spacer;"
                    ": list_box { key = \"lst\"; width = 50; fixed_width = true; height = 15; "
                    "fixed_height = true; allow_accept = true; "
                    "multiple_select = " (if mtp "true" "false") "; }"
                    ": edit_box { key = \"flt\"; width = 50; fixed_width = true; label = \"Filter:\"; }"
                    "spacer; ok_cancel; }"
                )
                des
            )
            (not (close des))
            (< 0 (setq dch (load_dialog dcl)))
            (new_dialog "blockpurge" dch)
        )
        (progn
            (BlockPurge:AddList "lst" (setq tmp lst))
            (set_tile "lst" (setq rtn "0"))
            (set_tile "flt" "*")
            (action_tile "lst" "(setq rtn $value)")
            (action_tile "flt"
                (vl-prin1-to-string
                   '(progn
                        ;; Remember what is currently selected, by value.
                        (setq flt (strcat "*" (strcase $value) "*")
                              sel (mapcar (function (lambda ( n ) (nth n tmp)))
                                          (read (strcat "(" rtn ")"))
                              )
                        )
                        ;; Rebuild the list to matching entries only.
                        (BlockPurge:AddList "lst"
                            (setq tmp (vl-remove-if-not
                                          (function (lambda ( x ) (wcmatch (strcase x) flt)))
                                          lst
                                      )
                            )
                        )
                        ;; Re-select whichever of them survived the filter,
                        ;; falling back to the first entry if none did.
                        (set_tile "lst"
                            (setq rtn
                                (vl-string-trim "()"
                                    (vl-princ-to-string
                                        (cond
                                            ((vl-sort (vl-remove nil
                                                          (mapcar (function (lambda ( x ) (vl-position x tmp))) sel)
                                                      )
                                                     '<
                                             )
                                            )
                                            ('(0))
                                        )
                                    )
                                )
                            )
                        )
                    )
                )
            )
            (setq rtn
                (if (= 1 (start_dialog))
                    (mapcar (function (lambda ( x ) (nth x tmp))) (read (strcat "(" rtn ")")))
                )
            )
        )
    )

    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
    rtn
)

;; ---------------------------------------------------------------------------
;; c:BLOCKPURGE  -  main routine
;; ---------------------------------------------------------------------------
(defun c:BLOCKPURGE ( / *error* vars vals def names sel done )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun BlockPurge: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 )
        (BlockPurge:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BLOCKPURGE error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; ------------------------------------------------------------------
    ;; Build the list of offerable block names. The DXF 70 mask 125 covers
    ;; every flag that marks a block as not directly deletable: anonymous,
    ;; xref, xref overlay, xref-dependent, and external reference. Only
    ;; definitions with none of those set are listed.
    ;; ------------------------------------------------------------------
    (while (setq def (tblnext "block" (not def)))
        (if (zerop (logand 125 (cdr (assoc 70 def))))
            (setq names (cons (cdr (assoc 2 def)) names))
        )
    )
    (setq names (vl-sort names '<))

    (while
        (and (or names (princ "\nNo deletable blocks are defined in this drawing."))
             (progn
                 (setvar 'errno 0)
                 (initget "Name Exit")
                 (setq sel (entsel "\nSelect a block to delete [Name/Exit] <Exit>: "))
                 (cond
                     (   (= 7 (getvar 'errno))
                         (princ "\nMissed, try again.")
                     )
                     (   (or (null sel) (= "Exit" sel))
                         nil
                     )

                     ;; Choose by name from the filtered list.
                     (   (= "Name" sel)
                         (if (setq done (BlockPurge:FilterListBox "Select Blocks to Delete" names t))
                             (setq done  (BlockPurge:Run done)
                                   names (vl-remove-if
                                             (function (lambda ( x ) (member (strcase x) done)))
                                             names
                                         )
                             )
                         )
                         nil
                     )

                     (   (/= "INSERT" (cdr (assoc 0 (entget (car sel)))))
                         (princ "\nThat object is not a block.")
                     )

                     ;; Picked in the drawing - delete that one and carry on.
                     (   t
                         (setq done  (BlockPurge:Run
                                         (list (BlockPurge:BlockName
                                                   (vlax-ename->vla-object (car sel))
                                               )
                                         )
                                     )
                               names (vl-remove-if
                                         (function (lambda ( x ) (member (strcase x) done)))
                                         names
                                     )
                         )
                         t
                     )
                 )
             )
        )
    )

    (BlockPurge:Restore)
    (princ)
)

(princ)