;;; ---------------------------------------------------------------------------
;;; AutoTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Keeps an attribute automatically numbered, renumbering the whole set
;;; whenever blocks are added, copied or erased.
;;;
;;; Insert another block and it takes the next number. Delete one from the
;;; middle and everything after it closes up. Copy three and they number
;;; themselves. You never renumber anything by hand.
;;;
;;; This is what you want for grid references, pile numbers, tree tags, sample
;;; points - anything where the sequence must stay complete and in order.
;;;
;;; COMMANDS
;;;   AUTOTAGON   - enable automatic numbering
;;;   AUTOTAGOFF  - disable it
;;;
;;; Numbering is enabled on load if AutoTag:Startup is set - so putting this in
;;; your acaddoc.lsp makes it permanent.
;;;
;;; CONFIGURE IT FIRST - see the settings block below. It ships pointed at a
;;; block called "myblock" and a tag called "mytag", which will match nothing
;;; in a real drawing. Both accept wildcards, so "GRID*" matches every block
;;; whose name starts with GRID.
;;;
;;; NUMBERING ORDER
;;; Blocks are numbered in DATABASE order - the order in which they were
;;; created - not by position on the drawing. If you need them numbered
;;; left-to-right or along a path, this is not the tool; use NUMINC instead.
;;;
;;; HOW IT WORKS - AND WHY THERE ARE TWO REACTORS
;;; An OBJECT reactor watches the numbered blocks for erase, copy and unerase.
;;; But it fires DURING a command, when the drawing is mid-edit and renumbering
;;; would be unsafe. So it does not renumber - it creates a COMMAND reactor,
;;; which fires once the command has finished and the database is settled. That
;;; second reactor does the renumbering and then removes itself.
;;;
;;; The object reactor is also detached while renumbering runs, or the changes
;;; it makes would trigger it again and recurse indefinitely.
;;;
;;; UNDO IS DELIBERATELY IGNORED
;;; A flag records when the UNDO command is running and suppresses renumbering.
;;; Without it, undoing a deletion would immediately be followed by a renumber,
;;; which is not what "undo" means.
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; SETTINGS - edit these before use.
;;; ---------------------------------------------------------------------------

(setq AutoTag:BlockName "myblock")  ; block to number; wildcards allowed
(setq AutoTag:BlockTag  "mytag")    ; attribute tag to fill; wildcards allowed
(setq AutoTag:Prefix    "")         ; numbering prefix, "" for none
(setq AutoTag:Suffix    "")         ; numbering suffix, "" for none
(setq AutoTag:Start     1)          ; first number
(setq AutoTag:Length    2)          ; fixed digits: 2 gives 01, 02 ... 0 = none
(setq AutoTag:Startup   t)          ; enable when this file loads
(setq AutoTag:ObjType   3)          ; 1 = attributed blocks, 2 = multileaders,
                                    ; 3 = both

;; The data tag identifying this routine's reactors.
(setq AutoTag:Key "autotag")

;;; ---------------------------------------------------------------------------
;;; REACTOR STATE
;;;
;;; These cannot be localised: reactor callbacks fire long after the command
;;; that created them has returned, so their state must persist globally.
;;; ---------------------------------------------------------------------------
(setq *AutoTag:ObjectReactor*  nil   ; watches the numbered blocks
      *AutoTag:CommandReactor* nil   ; created on demand, does the renumbering
      *AutoTag:UndoFlag*       nil   ; true while UNDO is running
      *AutoTag:TagIds*         nil   ; cache of block name -> attribute tag ids
)

;; ---------------------------------------------------------------------------
;; AutoTag:Filter
;; ---------------------------------------------------------------------------
;; Returns the ssget filter selecting everything that should be numbered.
;;
;; Built from the object-type setting: attributed blocks, multileaders, or both
;; wrapped in an OR. The "`*U*" added to the block name pattern admits
;; anonymous names, so modified dynamic blocks are not missed - their real
;; names are checked individually afterwards.
;;
;; The final clause confines the search to the current space, so numbering on
;; one sheet is independent of another.
;; ---------------------------------------------------------------------------
(defun AutoTag:Filter ( )
    (append
        (if (= 3 (logand 3 AutoTag:ObjType)) '((-4 . "<OR")))
        (if (= 1 (logand 1 AutoTag:ObjType))
            (list '(-4 . "<AND") '(0 . "INSERT") '(66 . 1)
                   (cons 2 (strcat "`*U*," AutoTag:BlockName))
                  '(-4 . "AND>")
            )
        )
        (if (= 2 (logand 2 AutoTag:ObjType)) '((0 . "MULTILEADER")))
        (if (= 3 (logand 3 AutoTag:ObjType)) '((-4 . "OR>")))
        (if (= 1 (getvar 'cvport))
            (list (cons 410 (getvar 'ctab)))
           '((410 . "Model"))
        )
    )
)

;; ---------------------------------------------------------------------------
;; Version-tolerant property accessors.
;;
;; Each tests once which form this AutoCAD supports and then replaces itself,
;; so the test does not repeat on every block. The 32-bit variants are the
;; newer forms, needed on 64-bit AutoCAD where the plain ones overflow.
;; ---------------------------------------------------------------------------

(defun AutoTag:ObjectId ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun AutoTag:ObjectId ( obj ) (vla-get-objectid32 obj))
        (defun AutoTag:ObjectId ( obj ) (vla-get-objectid   obj))
    )
    (AutoTag:ObjectId obj)
)

(defun AutoTag:SetBlockAttribute ( obj idx str )
    (if (vlax-method-applicable-p obj 'setblockattributevalue32)
        (defun AutoTag:SetBlockAttribute ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
        (defun AutoTag:SetBlockAttribute ( obj idx str ) (vla-setblockattributevalue   obj idx str))
    )
    (AutoTag:SetBlockAttribute obj idx str)
)

;; Returns a block reference's real name - a modified dynamic block is stored
;; under an anonymous "*U" name, which would never match the configured
;; pattern.
(defun AutoTag:EffectiveName ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (defun AutoTag:EffectiveName ( obj ) (strcase (vla-get-effectivename obj)))
        (defun AutoTag:EffectiveName ( obj ) (strcase (vla-get-name obj)))
    )
    (AutoTag:EffectiveName obj)
)

;; ---------------------------------------------------------------------------
;; AutoTag:PadZeros
;; ---------------------------------------------------------------------------
;; Left-pads with zeros to a fixed width. A number already longer is returned
;; unchanged rather than truncated - better an inconsistent width than a wrong
;; number.
;; ---------------------------------------------------------------------------
(defun AutoTag:PadZeros ( str len )
    (if (< (strlen str) len)
        (AutoTag:PadZeros (strcat "0" str) len)
        str
    )
)

;; ---------------------------------------------------------------------------
;; AutoTag:Label
;; ---------------------------------------------------------------------------
;; Returns the finished label for a number, with prefix, padding and suffix.
;; ---------------------------------------------------------------------------
(defun AutoTag:Label ( num )
    (strcat AutoTag:Prefix
            (AutoTag:PadZeros (itoa num) AutoTag:Length)
            AutoTag:Suffix
    )
)

;; ---------------------------------------------------------------------------
;; AutoTag:GetAttribute
;; ---------------------------------------------------------------------------
;; Returns the attribute object matching the configured tag on a block
;; reference, or nil if the block does not match or has no such tag.
;;
;; The original tested the wrong variable here - it checked a variable named
;; obj rather than its own parameter, which worked only because every caller
;; happened to use that name for the block. Fixed to test the parameter.
;;
;; blk - [vla-object] the block reference
;; ---------------------------------------------------------------------------
(defun AutoTag:GetAttribute ( blk )
    (if (wcmatch (AutoTag:EffectiveName blk) AutoTag:BlockName)
        (vl-some
            (function
                (lambda ( att )
                    (if (wcmatch (strcase (vla-get-tagstring att)) AutoTag:BlockTag) att)
                )
            )
            (vlax-invoke blk 'getattributes)
        )
    )
)

;; ---------------------------------------------------------------------------
;; AutoTag:GetTagId
;; ---------------------------------------------------------------------------
;; Returns the object ID of the matching attribute definition within a block,
;; which is how a multileader's block content is addressed.
;;
;; Multileaders do not expose their attributes as objects - a value is set by
;; naming the attribute DEFINITION's id inside the block. Finding that means
;; walking the block definition, which is slow, so results are cached per block
;; name in the global list.
;;
;; This function rewrites itself on first call so the caching version becomes
;; the permanent one.
;; ---------------------------------------------------------------------------
(defun AutoTag:GetTagId ( blk )
    (eval
        (list 'defun 'AutoTag:GetTagId '( blk / itm tmp )
            (list 'if
               '(setq itm (assoc (strcase blk) *AutoTag:TagIds*))
               '(cdar (vl-member-if
                          (function (lambda ( att ) (wcmatch (car att) AutoTag:BlockTag)))
                          (cdr itm)
                      )
                )
                (list 'progn
                    (list 'vlax-for 'obj
                        (list 'vla-item
                              (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
                              'blk
                        )
                       '(if (and (= "AcDbAttributeDefinition" (vla-get-objectname obj))
                                 ;; Constant attributes cannot be set, so they
                                 ;; are not worth caching.
                                 (= :vlax-false (vla-get-constant obj))
                            )
                            (setq tmp (cons (cons (strcase (vla-get-tagstring obj))
                                                  (AutoTag:ObjectId obj)
                                            )
                                            tmp
                                      )
                            )
                        )
                    )
                   '(setq *AutoTag:TagIds* (cons (cons (strcase blk) tmp) *AutoTag:TagIds*))
                   '(AutoTag:GetTagId blk)
                )
            )
        )
    )
    (AutoTag:GetTagId blk)
)

;; ---------------------------------------------------------------------------
;; AutoTag:Watch
;; ---------------------------------------------------------------------------
;; Adds an object to those the object reactor watches, if not already watched.
;; ---------------------------------------------------------------------------
(defun AutoTag:Watch ( obj )
    (if (and (= 'vlr-object-reactor (type *AutoTag:ObjectReactor*))
             (not (member obj (vlr-owners *AutoTag:ObjectReactor*)))
        )
        (vlr-owner-add *AutoTag:ObjectReactor* obj)
    )
)

;; ---------------------------------------------------------------------------
;; AutoTag:OnModified  -  object reactor callback
;; ---------------------------------------------------------------------------
;; Fires when a numbered object is erased, copied or unerased.
;;
;; It does NOT renumber. The drawing is mid-command at this point, so it
;; creates a command reactor that will renumber once the command is over. See
;; the note in the header.
;; ---------------------------------------------------------------------------
(defun AutoTag:OnModified ( owner reactor args )
    (if (null *AutoTag:CommandReactor*)
        (setq *AutoTag:CommandReactor*
            (vlr-command-reactor AutoTag:Key
               '(
                    (:vlr-commandEnded     . AutoTag:Renumber)
                    (:vlr-commandCancelled . AutoTag:Abandon)
                    (:vlr-commandFailed    . AutoTag:Abandon)
                )
            )
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:Abandon  -  command cancelled or failed
;; ---------------------------------------------------------------------------
;; Removes the pending command reactor without renumbering. A cancelled command
;; changed nothing, so renumbering would be wrong - and leaving the reactor
;; armed would make the NEXT command trigger a spurious renumber.
;; ---------------------------------------------------------------------------
(defun AutoTag:Abandon ( reactor args )
    (if (= 'vlr-command-reactor (type *AutoTag:CommandReactor*))
        (progn
            (vlr-remove *AutoTag:CommandReactor*)
            (setq *AutoTag:CommandReactor* nil)
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:Renumber  -  the actual renumbering
;; ---------------------------------------------------------------------------
;; Renumbers every matching object in the current space, in database order.
;;
;; The object reactor is detached first and reattached afterwards, or the edits
;; made here would retrigger it and recurse.
;;
;; The counter only advances when a label is actually written, so a block that
;; matches the name but lacks the tag does not consume a number and leave a gap
;; in the sequence.
;; ---------------------------------------------------------------------------
(defun AutoTag:Renumber ( reactor args / att blk idx num obj oid sel )

    (AutoTag:Abandon nil nil)

    (if (= 'vlr-object-reactor (type *AutoTag:ObjectReactor*))
        (vlr-remove *AutoTag:ObjectReactor*)
    )

    (if (and (not *AutoTag:UndoFlag*)
             (setq sel (ssget "_X" (AutoTag:Filter)))
        )
        (progn
            (setq num AutoTag:Start)
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))

                (if (wcmatch (vla-get-objectname obj) "AcDbBlockReference,AcDbMInsertBlock")
                    ;; An ordinary attributed block, including multiple-insert
                    ;; blocks.
                    (if (setq att (AutoTag:GetAttribute obj))
                        (progn
                            (vla-put-textstring att (AutoTag:Label num))
                            (setq num (1+ num))
                            (AutoTag:Watch obj)
                        )
                    )
                    ;; A multileader whose content is a block.
                    (if (and (= acblockcontent (vla-get-contenttype obj))
                             (wcmatch (setq blk (strcase (vla-get-contentblockname obj)))
                                      AutoTag:BlockName)
                             (setq oid (AutoTag:GetTagId blk))
                        )
                        (progn
                            (AutoTag:SetBlockAttribute obj oid (AutoTag:Label num))
                            (setq num (1+ num))
                            (AutoTag:Watch obj)
                        )
                    )
                )
            )
        )
    )

    (if (= 'vlr-object-reactor (type *AutoTag:ObjectReactor*))
        (vlr-add *AutoTag:ObjectReactor*)
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:UndoCheck  -  :vlr-commandWillStart callback
;; ---------------------------------------------------------------------------
;; Records whether the command about to run is UNDO, so renumbering can be
;; suppressed for it. See the note in the header.
;; ---------------------------------------------------------------------------
(defun AutoTag:UndoCheck ( reactor args )
    (setq *AutoTag:UndoFlag* (= (strcase (car args) t) "undo"))
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:OnInsert  -  :vlr-commandEnded callback
;; ---------------------------------------------------------------------------
;; Numbers a newly inserted block without renumbering everything else.
;;
;; A full renumber on every insertion would be wasteful on a drawing with
;; hundreds of numbered blocks, so this counts how many already carry a number
;; and gives the new one the next value.
;;
;; The command name is checked against the insertion commands relevant to the
;; configured object types - there is no point running this after a ZOOM.
;; ---------------------------------------------------------------------------
(defun AutoTag:OnInsert ( reactor args / att blk ent enx idx new num obj oid sel )
    (if
        (and
            (not *AutoTag:UndoFlag*)
            (wcmatch (strcase (car args) t)
                (strcat
                    (if (= 1 (logand 1 AutoTag:ObjType)) "-insert,insert,executetool" "")
                    (if (= 3 (logand 3 AutoTag:ObjType)) "," "")
                    (if (= 2 (logand 2 AutoTag:ObjType)) "mleader" "")
                )
            )
            (setq ent (entlast))
            (setq new (vlax-ename->vla-object ent))
            (setq enx (entget ent))
            ;; Confirm the new object is genuinely one we number.
            (or (and (= 1 (logand 1 AutoTag:ObjType))
                     (= "INSERT" (cdr (assoc 0 enx)))
                     (= 1 (cdr (assoc 66 enx)))
                     (wcmatch (AutoTag:EffectiveName new) AutoTag:BlockName)
                )
                (and (= 2 (logand 2 AutoTag:ObjType))
                     (= "MULTILEADER" (cdr (assoc 0 enx)))
                     (= acblockcontent (vla-get-contenttype new))
                     (wcmatch (strcase (vla-get-contentblockname new)) AutoTag:BlockName)
                )
            )
            (setq sel (ssget "_X" (AutoTag:Filter)))
        )
        (progn
            ;; Count the existing numbered objects. Starting one BELOW the
            ;; start number means the count lands on the correct next value.
            (setq num (1- AutoTag:Start))
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                (if (wcmatch (vla-get-objectname obj) "AcDbBlockReference,AcDbMInsertBlock")
                    (if (AutoTag:GetAttribute obj)
                        (setq num (1+ num))
                    )
                    (if (and (= acblockcontent (vla-get-contenttype obj))
                             (wcmatch (setq blk (strcase (vla-get-contentblockname obj)))
                                      AutoTag:BlockName)
                             (AutoTag:GetTagId blk)
                        )
                        (setq num (1+ num))
                    )
                )
            )

            ;; Label the new object. Tested against the NEW object rather than
            ;; whatever the loop above happened to leave in obj.
            (if (wcmatch (vla-get-objectname new) "AcDbBlockReference,AcDbMInsertBlock")
                (if (setq att (AutoTag:GetAttribute new))
                    (progn
                        (vla-put-textstring att (AutoTag:Label num))
                        (AutoTag:Watch new)
                    )
                )
                (if (setq oid (AutoTag:GetTagId (vla-get-contentblockname new)))
                    (progn
                        (AutoTag:SetBlockAttribute new oid (AutoTag:Label num))
                        (AutoTag:Watch new)
                    )
                )
            )
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:Disable
;; ---------------------------------------------------------------------------
;; Removes every reactor belonging to this routine.
;;
;; Identified by data tag rather than by stored handle, so reactors left behind
;; by a previous load of this file are also found - otherwise repeatedly
;; loading it would stack duplicates that each renumber in turn.
;; ---------------------------------------------------------------------------
(defun AutoTag:Disable ( key )
    (foreach grp (vlr-reactors :vlr-command-reactor :vlr-object-reactor)
        (foreach obj (cdr grp)
            (if (= key (vlr-data obj)) (vlr-remove obj))
        )
    )
    (setq *AutoTag:UndoFlag*       nil
          *AutoTag:ObjectReactor*  nil
          *AutoTag:CommandReactor* nil
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; AutoTag:Enable
;; ---------------------------------------------------------------------------
;; Builds both reactors and performs an initial renumber.
;;
;; Both are set to active-document-only, so numbering in one open drawing does
;; not fire against another.
;; ---------------------------------------------------------------------------
(defun AutoTag:Enable ( key )

    (AutoTag:Disable key)

    (vlr-set-notification
        (setq *AutoTag:ObjectReactor*
            (vlr-object-reactor nil key
               '(
                    (:vlr-erased   . AutoTag:OnModified)
                    (:vlr-copied   . AutoTag:OnModified)
                    (:vlr-unerased . AutoTag:OnModified)
                )
            )
        )
        'active-document-only
    )

    (vlr-set-notification
        (vlr-command-reactor key
           '(
                (:vlr-commandWillStart . AutoTag:UndoCheck)
                (:vlr-commandEnded     . AutoTag:OnInsert)
            )
        )
        'active-document-only
    )

    ;; An initial pass, which also registers the existing blocks with the
    ;; object reactor so they are watched from now on.
    (AutoTag:Renumber nil nil)

    (princ
        (strcat "\nAutomatic numbering enabled for tags matching \"" AutoTag:BlockTag
                "\" within "
                (if (= 1 (logand 1 AutoTag:ObjType)) "blocks" "")
                (if (= 3 (logand 3 AutoTag:ObjType)) " and " "")
                (if (= 2 (logand 2 AutoTag:ObjType)) "multileaders" "")
                " matching \"" AutoTag:BlockName "\"."
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; LOAD-TIME VALIDATION AND COMMAND DEFINITION
;;;
;;; The settings are checked before the commands are defined at all, so a
;;; mistyped setting produces a clear message rather than a reactor that
;;; misbehaves silently later.
;;; ---------------------------------------------------------------------------
(   (lambda nil
        (cond
            (   (vl-some
                    (function
                        (lambda ( val par )
                            (if (/= 'str (type val))
                                (princ (strcat "\nAutoTag: the " par " setting must be a string."))
                            )
                        )
                    )
                    (list AutoTag:BlockName AutoTag:BlockTag AutoTag:Prefix AutoTag:Suffix)
                   '("block name" "attribute tag" "numbering prefix" "numbering suffix")
                )
            )

            (   (/= 'int (type AutoTag:Start))
                (princ "\nAutoTag: the starting number must be an integer.")
            )

            (   (/= 'int (type AutoTag:Length))
                (princ "\nAutoTag: the fixed length setting must be an integer.")
            )

            (   (not (and (= 'int (type AutoTag:ObjType))
                          (< 0 AutoTag:ObjType)
                          (< 0 (logand 3 AutoTag:ObjType))
                     )
                )
                (princ "\nAutoTag: the object type setting must be 1, 2 or 3.")
            )

            (   (setq AutoTag:BlockName (strcase AutoTag:BlockName)
                      AutoTag:BlockTag  (strcase AutoTag:BlockTag)
                )
                (defun c:AUTOTAGON nil
                    (AutoTag:Enable AutoTag:Key)
                )
                (defun c:AUTOTAGOFF nil
                    (AutoTag:Disable AutoTag:Key)
                    (princ "\nAutomatic numbering disabled.")
                    (princ)
                )
                (if AutoTag:Startup (AutoTag:Enable AutoTag:Key))
            )
        )
        (princ)
    )
)

(princ)