;;; ---------------------------------------------------------------------------
;;; TagBatch.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; SET BLOCK ATTRIBUTE VALUES ACROSS MANY DRAWINGS
;;;
;;; Build a list of "in this block, set this tag to this value", choose the
;;; drawings, and TagBatch applies the lot to every one of them.
;;;
;;; This is the revision letter that has to change on ninety title blocks,
;;; the project name that was wrong on every sheet, the drawn-by initials
;;; that need swapping when a job changes hands.
;;;
;;; ---------------------------------------------------------------------------
;;; BLOCK NAMES CAN BE PATTERNS
;;;
;;; The block name accepts AutoCAD wildcards, so one entry can cover a family
;;; of blocks that share a tag:
;;;
;;;   TITLE*        every block whose name starts with TITLE
;;;   *BORDER*      every block with BORDER anywhere in the name
;;;   A1-TB,A3-TB   either of two named blocks
;;;   *             every attributed block in the drawing
;;;
;;; Dynamic blocks are matched on their effective name, so the anonymous
;;; "*U27" names AutoCAD uses internally never have to be dealt with.
;;;
;;; ---------------------------------------------------------------------------
;;; THE VALUE CAN BE MORE THAN A FIXED STRING
;;;
;;; Three operators can appear anywhere inside a value, and can be combined
;;; with ordinary text and with each other.
;;;
;;;   <[TAG]>          the current value of another attribute in the SAME
;;;                    block. So a DESCRIPTION tag can be set to
;;;                    "<[NUMBER]> - <[NAME]>" and each block fills in its
;;;                    own values.
;;;
;;;   <L#n#L>          n plus the layout number, counting from zero in tab
;;;                    order. So "SHEET <L#1#L>" numbers the sheets of every
;;;                    drawing 1, 2, 3... in the order the tabs appear.
;;;
;;;   <D#n#D>          n plus the drawing number, counting through the
;;;                    drawings in the order you listed them. So
;;;                    "DWG-<D#100#D>" numbers a hundred drawings from 100
;;;                    upwards.
;;;
;;; The two counting operators take a number, add the counter to it, and
;;; write the result -- so the starting value is whatever you type. Combining
;;; them numbers every sheet of every drawing uniquely.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW IT WORKS
;;;
;;; Unlike most batch tools, TagBatch does NOT use ObjectDBX. It writes a
;;; script that opens each drawing properly, applies the changes, saves and
;;; closes.
;;;
;;; That is a deliberate trade. Opening each drawing is slower, but it is the
;;; only way the counting operators can work: the layout counter needs the
;;; real tab order, and both counters need to carry from one drawing to the
;;; next. The running counts are kept on the LISP blackboard, which is the
;;; one piece of memory that survives a drawing being closed.
;;;
;;; Three files are produced in the AutoCAD support folder:
;;;   * a script that drives the run;
;;;   * a small LISP file the script loads into each drawing, holding the
;;;     code that does the work;
;;;   * a settings file remembering the list and folder for next time.
;;;
;;; ---------------------------------------------------------------------------
;;; BUILDING THE LIST
;;;
;;; Three ways, and they mix freely:
;;;
;;;   TYPE IT       block name, tag and value in the three boxes, then Add.
;;;
;;;   PICK IT       Select Blocks reads every attributed block you select and
;;;                 offers its tags and current values as a checklist. Far
;;;                 quicker than typing, and it cannot misspell a tag.
;;;
;;;   LOAD IT       from a CSV or tab-separated text file of three columns:
;;;                 block, tag, value. Save works the same way, so a list
;;;                 built once can be reused on every project.
;;;
;;; Double-click any entry to edit it. The same block and tag cannot appear
;;; twice; duplicates are found and reported rather than silently applied in
;;; an unpredictable order.
;;;
;;; ---------------------------------------------------------------------------
;;; FILES IN USE
;;;
;;; Before running, each drawing is checked for a lock file. Any that are
;;; open elsewhere are listed and skipped rather than failing part-way
;;; through the run.
;;;
;;; ---------------------------------------------------------------------------
;;; IMPORTANT -- READ BEFORE RUNNING
;;;
;;; Every listed drawing is opened, modified and SAVED. There is no undo
;;; across files.
;;;
;;; Test on a copy of the folder first. Every time.
;;;
;;; ---------------------------------------------------------------------------
;;;   TAGBATCH - set attribute values across many drawings
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; TagBatch:FixDir
;;;
;;; Normalises a folder path: forward slashes become backslashes and any
;;; trailing backslash is removed.
;;; ---------------------------------------------------------------------------

(defun TagBatch:FixDir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:SavePath
;;;
;;; Where the script, helper and settings files live.
;;;
;;; These CANNOT be temporary files: the script runs after this command has
;;; ended, and loads the helper into each drawing as it goes. They must
;;; persist for the length of the run.
;;;
;;; The chain always succeeds, so nothing has to treat "nowhere to write" as
;;; a failure.
;;; ---------------------------------------------------------------------------

(defun TagBatch:SavePath ( / dir )
    (cond
        (   (and (setq dir (getvar 'roamablerootprefix))
                 (vl-file-directory-p (strcat (TagBatch:FixDir dir) "\\Support"))
            )
            (strcat (TagBatch:FixDir dir) "\\Support")
        )
        (   (setq dir (findfile "acad.pat"))
            (TagBatch:FixDir (vl-filename-directory dir))
        )
        (   (TagBatch:FixDir (vl-filename-directory (vl-filename-mktemp))))
    )
)

;;; ===========================================================================
;;; TAGBATCH
;;; ===========================================================================

(defun c:TagBatch

    ( /
        ;; ---- nested helper functions ----
        *error* TB:Restore TB:Validate TB:Confirm

        ;; ---- local variables ----
        base block cfg data dch dcl des dir dirdata files helper live
        result scr status tag tmp usable value vals vars work
    )

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

    (defun TB:Restore ( )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; TB:Confirm
    ;;;
    ;;; A yes/no question. Returns T for yes.
    ;;;
    ;;; Implemented as a DCL dialog rather than a Windows message box, which
    ;;; avoids creating and releasing a COM object for every confirmation --
    ;;; and this program asks a lot of them.
    ;;; -----------------------------------------------------------------------

    (defun TB:Confirm ( title msg / ok )
        (if (not (new_dialog "tb_confirm" dch))
            nil
            (progn
                (set_tile "ctitle" title)
                ;; The message tile is a list box so a long list of file names
                ;; scrolls rather than running off the screen.
                (start_list "ctext")
                (foreach line (TagBatch:Split msg "\n") (add_list line))
                (end_list)
                (action_tile "accept" "(setq ok t) (done_dialog)")
                (action_tile "cancel" "(done_dialog)")
                (start_dialog)
                ok
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; TB:Validate
    ;;;
    ;;; Checks the three entry boxes and, if they are sound, adds the entry to
    ;;; the list and clears them ready for the next.
    ;;;
    ;;; Three things are rejected: a missing block name, a missing tag, and a
    ;;; tag containing a space -- which AutoCAD does not allow but the edit
    ;;; box does. The same block and tag appearing twice is also rejected,
    ;;; because two entries for one attribute would be applied in whichever
    ;;; order the list happened to be sorted in.
    ;;; -----------------------------------------------------------------------

    (defun TB:Validate ( / clash )
        (cond
            (   (or (null block) (= "" block))
                (alert (strcat "Enter a block name.\n\n"
                               "Block names are not case-sensitive and may use wildcards "
                               "to match several blocks sharing the same tag."))
                (mode_tile "block" 2)
            )
            (   (or (null tag) (= "" tag))
                (alert (strcat "Enter an attribute tag.\n\n"
                               "Tags are not case-sensitive and cannot contain spaces."))
                (mode_tile "tag" 2)
            )
            (   (vl-string-position 32 tag)
                (alert "An attribute tag cannot contain spaces.")
                (mode_tile "tag" 2)
            )
            (   (setq clash
                    (vl-some
                       '(lambda ( item )
                            (if (and (= (car  item) (strcase block))
                                     (= (cadr item) (strcase tag))
                                )
                                item
                            )
                        )
                        data
                    )
                )
                (alert (strcat "The tag \"" (cadr clash) "\" in block \"" (car clash)
                               "\" is already in the list, set to \"" (caddr clash) "\"."))
                (mode_tile "block" 2)
            )
            (   t
                ;; An empty value is legitimate -- it blanks the attribute.
                (if (null value) (setq value ""))
                (setq data (TagBatch:ShowData "list"
                               (cons (list (strcase block) (strcase tag) value) data))
                      block nil
                      tag   nil
                      value nil
                )
                (foreach tile '("block" "tag" "value") (set_tile tile ""))
                (mode_tile "delitem" 1)
                (mode_tile "clear"   0)
                (mode_tile "save"    0)
                ;; Focus returns to the block box, ready for the next entry.
                (mode_tile "block"   2)
            )
        )
    )

    ;;; =======================================================================
    ;;;                       M A I N   R O U T I N E
    ;;; =======================================================================

    (setvar 'cmdecho 0)

    (setq work   (TagBatch:SavePath)
          base   (strcat work "\\YZ_TagBatch")
          helper (strcat base "_Helper.lsp")
          scr    (strcat base ".scr")
          cfg    (strcat base ".cfg")
    )

    ;; ---- write the helper LISP file ----------------------------------------
    ;; Always rewritten, never reused. An older version left behind by a
    ;; previous release would otherwise be loaded silently, and the failure
    ;; would appear as wrong values rather than as an error.

    (cond
        (   (not (TagBatch:WriteHelper helper))
            (alert (strcat "The helper file could not be written:\n\n" helper
                           "\n\nCheck that you have write permission for that folder."))
        )

        ;;  ---- build the dialog ------------------------------------------
        ;;  The dialog itself IS a temporary file, deleted on exit -- unlike
        ;;  the helper and script, nothing needs it after the command ends.
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line (TagBatch:DialogText) (write-line line des))
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                )
            )
            (alert "The program dialog could not be created.")
        )

        (   t
            ;; ---- restore the previous session's settings -----------------
            (if (setq tmp (TagBatch:ReadConfig cfg))
                (setq data   (car   tmp)
                      dir    (cadr  tmp)
                      result (caddr tmp)
                )
            )

            ;; Is there anything in this drawing worth picking? The Select
            ;; Blocks button is greyed out if not, rather than opening a
            ;; selection prompt that can only fail.
            (setq live
                (and (ssget "_X"
                         (list '(0 . "INSERT") '(66 . 1)
                               (cons 410 (if (= 1 (getvar 'cvport))
                                             (TagBatch:EscapeWild (getvar 'ctab))
                                             "Model"))))
                     t
                )
            )

            ;;; ---------------------------------------------------------------
            ;;; The dialog is a two-screen wizard. The status code returned by
            ;;; each screen decides what happens next:
            ;;;
            ;;;   nil or 3 - show the attribute data screen
            ;;;   2        - show the drawing selection screen
            ;;;   4        - go and pick blocks from the drawing, then return
            ;;;   1        - run
            ;;;   0        - cancel
            ;;; ---------------------------------------------------------------

            (while (not (member status '(1 0)))
                (cond

                    ;;  ============ screen one: the attribute list ============
                    (   (or (null status) (= 3 status))
                        (if (not (new_dialog "tb_data" dch))
                            (progn (alert "The program dialog could not be displayed.")
                                   (setq status 0))
                            (progn
                                ;; Buttons that act on the list are disabled
                                ;; while the list is empty, so the dialog
                                ;; shows what is possible rather than
                                ;; complaining afterwards.
                                (if data
                                    (progn
                                        (setq data (TagBatch:ShowData "list" data))
                                        (mode_tile "clear" 0)
                                        (mode_tile "save"  0)
                                    )
                                    (progn
                                        (mode_tile "clear" 1)
                                        (mode_tile "save"  1)
                                    )
                                )
                                (mode_tile "delitem" 1)
                                (mode_tile "select" (if live 0 1))
                                ;; The three column headings are separate
                                ;; single-item list boxes, which is how a DCL
                                ;; list box gets a header row that does not
                                ;; scroll with the data.
                                (mapcar 'TagBatch:FillList
                                       '("h1" "h2" "h3")
                                       '(("\tBlock") ("\tTag") ("\tValue")))

                                ;;; -------------------------------------------
                                ;;; Callbacks.
                                ;;;
                                ;;; Written as quoted lists and converted with
                                ;;; vl-prin1-to-string, which produces correct
                                ;;; quoting every time where hand-escaping
                                ;;; does not.
                                ;;;
                                ;;; $reason 1 means Enter was pressed or the
                                ;;; field was left; the three entry boxes chain
                                ;;; focus onward so the whole entry can be
                                ;;; typed without touching the mouse.
                                ;;; -------------------------------------------

                                (action_tile "block"
                                    (vl-prin1-to-string
                                       '(progn
                                            (setq block $value)
                                            (if (= 1 $reason) (mode_tile "tag" 2))
                                        )
                                    )
                                )
                                (action_tile "tag"
                                    (vl-prin1-to-string
                                       '(progn
                                            (setq tag $value)
                                            (if (= 1 $reason) (mode_tile "value" 2))
                                        )
                                    )
                                )
                                (action_tile "value"
                                    (vl-prin1-to-string
                                       '(progn
                                            (setq value $value)
                                            (if (= 1 $reason) (TB:Validate))
                                        )
                                    )
                                )
                                (action_tile "additem" "(TB:Validate)")
                                (action_tile "select"  "(done_dialog 4)")

                                ;;  $reason 4 is a double-click, which edits
                                ;;  the entry. Afterwards the highlight is put
                                ;;  back on the entry as it now stands, which
                                ;;  has usually moved because the list re-sorts.
                                (action_tile "list"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / item was )
                                                (mode_tile "delitem" 0)
                                                (if (= 4 $reason)
                                                    (progn
                                                        (setq item (nth (atoi $value) data)
                                                              was  data
                                                              data (TagBatch:ShowData "list"
                                                                       (TagBatch:EditItem dch item data))
                                                        )
                                                        (set_tile "list" "")
                                                        (set_tile "list"
                                                            (if (equal was data)
                                                                ;; Cancelled: nothing moved.
                                                                $value
                                                                (itoa (vl-position
                                                                          (car (vl-remove-if
                                                                                   '(lambda ( x ) (member x was))
                                                                                    data))
                                                                          data))
                                                            )
                                                        )
                                                    )
                                                )
                                            )
                                        )
                                    )
                                )

                                (action_tile "delitem"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / items )
                                                (if (setq items (read (strcat "("
                                                                              (get_tile "list") ")")))
                                                    (setq data (TagBatch:ShowData "list"
                                                                   (TagBatch:RemoveNth items data)))
                                                )
                                                (mode_tile "delitem" 1)
                                                (if (null data)
                                                    (progn
                                                        (mode_tile "clear" 1)
                                                        (mode_tile "save"  1)
                                                    )
                                                )
                                            )
                                        )
                                    )
                                )

                                (action_tile "load"
                                    (vl-prin1-to-string
                                       '(if (setq tmp (TagBatch:LoadFromFile dch))
                                            (progn
                                                (setq data (TagBatch:ShowData "list" tmp))
                                                (mode_tile "clear" 0)
                                                (mode_tile "save"  0)
                                                (mode_tile "block" 2)
                                            )
                                        )
                                    )
                                )
                                (action_tile "clear"
                                    (vl-prin1-to-string
                                       '(progn
                                            (setq data (TagBatch:ShowData "list" nil))
                                            (mode_tile "delitem" 1)
                                            (mode_tile "clear"   1)
                                            (mode_tile "save"    1)
                                        )
                                    )
                                )
                                (action_tile "save" "(TagBatch:SaveToFile data)")

                                (action_tile "accept"
                                    (vl-prin1-to-string
                                       '(if (null data)
                                            (alert (strcat
                                                "There is nothing in the list.\n\n"
                                                "Enter a block name, an attribute tag and a new "
                                                "value in the boxes at the top, then click "
                                                "Add Item."))
                                            (done_dialog 2)
                                        )
                                    )
                                )
                                (action_tile "cancel" "(done_dialog 0)")
                                (setq status (start_dialog))
                            )
                        )
                    )

                    ;;  ============ screen two: the drawings ============
                    (   (= 2 status)
                        (if (not (new_dialog "tb_files" dch))
                            (progn (alert "The program dialog could not be displayed.")
                                   (setq status 0))
                            (progn
                                ;; A remembered folder that no longer exists
                                ;; falls back to the current drawing's folder.
                                (set_tile "directory"
                                    (setq dir
                                        (TagBatch:FixDir
                                            (if (or (null dir)
                                                    (null (vl-file-directory-p (TagBatch:FixDir dir))))
                                                (getvar 'dwgprefix)
                                                dir
                                            )
                                        )
                                    )
                                )
                                (setq files  (TagBatch:ShowFolder dir result)
                                      result (TagBatch:ShowChosen dir result)
                                )
                                (mode_tile "add" 1)
                                (mode_tile "del" 1)
                                ;; The reorder buttons are greyed according to
                                ;; what is selected: nothing at the top can
                                ;; move up, nothing at the bottom can move
                                ;; down, and an empty list can do neither.
                                (mapcar 'mode_tile '("top" "up" "down" "bottom" "sort")
                                        (TagBatch:ButtonModes nil result))

                                (action_tile "browse"
                                    (vl-prin1-to-string
                                       '(if (setq tmp (TagBatch:PickFolder "" nil 512))
                                            (mapcar 'mode_tile '("top" "up" "down" "bottom" "sort")
                                                (TagBatch:ButtonModes nil
                                                    (setq files (TagBatch:ShowFolder
                                                                    (set_tile "directory" (setq dir tmp))
                                                                    result)
                                                          result (TagBatch:ShowChosen dir result))))
                                        )
                                    )
                                )
                                (action_tile "directory"
                                    (vl-prin1-to-string
                                       '(if (= 1 $reason)
                                            (mapcar 'mode_tile '("top" "up" "down" "bottom" "sort")
                                                (TagBatch:ButtonModes nil
                                                    (setq files (TagBatch:ShowFolder
                                                                    (set_tile "directory"
                                                                        (setq dir (TagBatch:FixDir $value)))
                                                                    result)
                                                          result (TagBatch:ShowChosen dir result))))
                                        )
                                    )
                                )

                                ;;  Left pane: double-click navigates into a
                                ;;  folder, up out of one, or adds files.
                                (action_tile "box1"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / index items where )
                                                (setq index (read (strcat "(" $value ")"))
                                                      items (mapcar '(lambda ( n ) (nth n files)) index)
                                                )
                                                (if (= 4 $reason)
                                                    (progn
                                                        (cond
                                                            (   (equal '("..") items)
                                                                (setq files (TagBatch:ShowFolder
                                                                                (set_tile "directory"
                                                                                    (setq dir (TagBatch:UpDir dir)))
                                                                                result)
                                                                      result (TagBatch:ShowChosen dir result))
                                                            )
                                                            (   (vl-file-directory-p
                                                                    (setq where (TagBatch:Redirect
                                                                                    (strcat dir "\\" (car items)))))
                                                                (setq files (TagBatch:ShowFolder
                                                                                (set_tile "directory" (setq dir where))
                                                                                result)
                                                                      result (TagBatch:ShowChosen dir result))
                                                            )
                                                            (   t
                                                                (setq result (TagBatch:ShowChosen dir
                                                                                 (append result
                                                                                     (mapcar '(lambda ( f )
                                                                                                  (strcat dir "\\" f))
                                                                                             items)))
                                                                      files  (TagBatch:ShowFolder dir result))
                                                            )
                                                        )
                                                        (setq index nil)
                                                        (mode_tile "add" 1)
                                                    )
                                                    ;; Single click: Add is
                                                    ;; only useful if at least
                                                    ;; one real file is chosen.
                                                    (if (vl-some 'vl-filename-extension items)
                                                        (mode_tile "add" 0)
                                                    )
                                                )
                                                (mapcar 'mode_tile '("top" "up" "down" "bottom" "sort")
                                                        (TagBatch:ButtonModes index result))
                                            )
                                        )
                                    )
                                )

                                ;;  Right pane: double-click removes an entry.
                                (action_tile "box2"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / index items )
                                                (setq index (read (strcat "(" $value ")"))
                                                      items (mapcar '(lambda ( n ) (nth n result)) index)
                                                )
                                                (if (= 4 $reason)
                                                    (setq result (TagBatch:ShowChosen dir
                                                                     (vl-remove (car items) result))
                                                          files  (TagBatch:ShowFolder dir result)
                                                          index  nil
                                                    )
                                                    (mode_tile "del" 0)
                                                )
                                                (mapcar 'mode_tile '("top" "up" "down" "bottom" "sort")
                                                        (TagBatch:ButtonModes index result))
                                            )
                                        )
                                    )
                                )

                                ;;  The four reorder buttons all do the same
                                ;;  thing with a different function, so their
                                ;;  callbacks are generated rather than
                                ;;  written out four times. Each reorder
                                ;;  function returns both the new order AND
                                ;;  the new positions of the moved items, so
                                ;;  the highlight follows them.
                                (mapcar
                                   '(lambda ( key fn )
                                        (action_tile key
                                            (vl-prin1-to-string
                                                (list
                                                    (list 'lambda '( / items )
                                                        (list 'if
                                                           '(setq items (read (strcat "("
                                                                                      (get_tile "box2") ")")))
                                                            (list 'apply
                                                                (list 'function
                                                                   '(lambda ( idx lst )
                                                                        (setq result (TagBatch:ShowChosen dir lst))
                                                                        (set_tile "box2"
                                                                            (vl-string-trim "()"
                                                                                (vl-princ-to-string idx)))
                                                                        (mapcar 'mode_tile
                                                                               '("top" "up" "down" "bottom" "sort")
                                                                                (TagBatch:ButtonModes idx lst))
                                                                    )
                                                                )
                                                                (list fn 'items 'result)
                                                            )
                                                        )
                                                    )
                                                )
                                            )
                                        )
                                    )
                                   '("top" "up" "down" "bottom")
                                   '(TagBatch:ListTop TagBatch:ListUp
                                     TagBatch:ListDown TagBatch:ListBottom)
                                )

                                (action_tile "sort"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / index items )
                                                (if result
                                                    (progn
                                                        ;; The highlighted files
                                                        ;; are remembered by
                                                        ;; name, so the
                                                        ;; highlight follows
                                                        ;; them through the sort.
                                                        (setq items (mapcar '(lambda ( n ) (nth n result))
                                                                            (read (strcat "("
                                                                                          (get_tile "box2") ")"))))
                                                        (setq result (TagBatch:ShowChosen dir
                                                                         (TagBatch:FileSort result)))
                                                        (set_tile "box2" "")
                                                        (if (setq index
                                                                (vl-sort
                                                                    (vl-remove nil
                                                                        (mapcar '(lambda ( f )
                                                                                     (vl-position f result))
                                                                                items))
                                                                   '<))
                                                            (set_tile "box2"
                                                                (vl-string-trim "()"
                                                                    (vl-princ-to-string index)))
                                                        )
                                                        (mapcar 'mode_tile
                                                               '("top" "up" "down" "bottom" "sort")
                                                                (TagBatch:ButtonModes index result))
                                                    )
                                                )
                                            )
                                        )
                                    )
                                )

                                (action_tile "add"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / items )
                                                ;; Folders caught in a drag
                                                ;; selection are dropped; only
                                                ;; things with an extension are
                                                ;; files.
                                                (if (setq items
                                                        (vl-remove-if-not 'vl-filename-extension
                                                            (mapcar '(lambda ( n ) (nth n files))
                                                                    (read (strcat "("
                                                                                  (get_tile "box1") ")")))))
                                                    (progn
                                                        (setq result (TagBatch:ShowChosen dir
                                                                         (append result
                                                                             (mapcar '(lambda ( f )
                                                                                          (strcat dir "\\" f))
                                                                                     items)))
                                                              files  (TagBatch:ShowFolder dir result)
                                                        )
                                                        (mapcar 'mode_tile
                                                               '("top" "up" "down" "bottom" "sort")
                                                                (TagBatch:ButtonModes nil result))
                                                    )
                                                )
                                                (mode_tile "add" 1)
                                                (mode_tile "del" 1)
                                            )
                                        )
                                    )
                                )

                                (action_tile "del"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / items )
                                                (if (setq items (read (strcat "("
                                                                              (get_tile "box2") ")")))
                                                    (progn
                                                        (setq result (TagBatch:ShowChosen dir
                                                                         (TagBatch:RemoveNth items result))
                                                              files  (TagBatch:ShowFolder dir result)
                                                        )
                                                        (mapcar 'mode_tile
                                                               '("top" "up" "down" "bottom" "sort")
                                                                (TagBatch:ButtonModes nil result))
                                                    )
                                                )
                                                (mode_tile "add" 1)
                                                (mode_tile "del" 1)
                                            )
                                        )
                                    )
                                )

                                (action_tile "back" "(done_dialog 3)")

                                ;;  OK: check that the drawings can actually
                                ;;  be opened before starting a run that
                                ;;  cannot finish.
                                (action_tile "accept"
                                    (vl-prin1-to-string
                                       '(
                                            (lambda ( / locked )
                                                (cond
                                                    (   (null result)
                                                        (alert (strcat
                                                            "No drawings have been selected.\n\n"
                                                            "Navigate with the left-hand list, the "
                                                            "Browse button, or by typing a folder "
                                                            "and pressing Enter. Then double-click "
                                                            "a file, or select several and click "
                                                            "Add Files."))
                                                    )
                                                    (   (progn
                                                            (setq tmp (TagBatch:CheckLocks result)
                                                                  usable (car  tmp)
                                                                  locked (cadr tmp)
                                                            )
                                                            (null usable)
                                                        )
                                                        (alert (strcat
                                                            "Every selected drawing is currently "
                                                            "open elsewhere and cannot be "
                                                            "processed:\n\n"
                                                            (TagBatch:Join locked "\n")))
                                                    )
                                                    (   locked
                                                        (if (TB:Confirm "Files in Use"
                                                                (strcat
                                                                    "These drawings are open elsewhere "
                                                                    "and will be skipped:\n"
                                                                    (TagBatch:Join locked "\n")
                                                                    "\n\nContinue with the rest?"))
                                                            (done_dialog 1)
                                                        )
                                                    )
                                                    (   (done_dialog 1))
                                                )
                                            )
                                        )
                                    )
                                )
                                (action_tile "cancel" "(done_dialog 0)")
                                (setq status (start_dialog))
                            )
                        )
                    )

                    ;;  ============ pick blocks from the drawing ============
                    (   (= 4 status)
                        (setq data   (TagBatch:SelectBlocks dch data)
                              status 3
                        )
                    )
                )
            )

            ;;; ---------------------------------------------------------------
            ;;; Write the script and run it.
            ;;; ---------------------------------------------------------------

            (if (/= 1 status)
                (princ "\nCancelled.")
                (progn
                    (TagBatch:WriteConfig cfg data dir result)

                    (if (null (setq des (open scr "w")))
                        (alert (strcat "The script file could not be written:\n\n" scr
                                       "\n\nCheck that you have write permission for that folder."))
                        (progn
                            ;; One line per drawing. Each opens the file,
                            ;; loads the helper, applies the data, advances
                            ;; the drawing counter, and saves and closes.
                            ;;
                            ;; QSAVE appears twice deliberately: if the
                            ;; drawing is in an older format the first is
                            ;; consumed by the format prompt, and a script
                            ;; cannot branch on that.
                            (foreach name usable
                                (write-line
                                    (strcat
                                        "_.open \"" name "\" "
                                        "(load " (vl-prin1-to-string helper) " nil) "
                                        "(if (and TagBatch:Apply (vl-bb-ref 'TagBatch:data)) "
                                        "(TagBatch:Apply (vl-bb-ref 'TagBatch:data))) "
                                        "(if (vl-bb-ref 'TagBatch:dwgcount) "
                                        "(vl-bb-set 'TagBatch:dwgcount "
                                        "(1+ (vl-bb-ref 'TagBatch:dwgcount)))) "
                                        "_.qsave _.qsave _.close"
                                    )
                                    des
                                )
                            )
                            (setq des (close des))

                            ;; The blackboard is the only memory that survives
                            ;; a drawing closing, so the data and the running
                            ;; counter are passed through it.
                            (vl-bb-set 'TagBatch:data     (TagBatch:GroupByBlock data))
                            (vl-bb-set 'TagBatch:dwgcount 0)

                            (princ (strcat "\nProcessing " (itoa (length usable)) " drawing"
                                           (if (= 1 (length usable)) "" "s") "..."))

                            ;; Everything is cleaned up BEFORE the script
                            ;; starts: SCRIPT hands control to the script file
                            ;; and does not come back here, so anything left
                            ;; until afterwards would never happen.
                            (TB:Restore)
                            (vl-cmdf "_.script" scr)
                        )
                    )
                )
            )
        )
    )

    (TB:Restore)
    (princ)
)

;;; ===========================================================================
;;;                    T H E   H E L P E R   F I L E
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:WriteHelper
;;;
;;; Writes the small LISP file that the script loads into each drawing.
;;;
;;; This code cannot simply be part of this file: the script closes each
;;; drawing, and closing a drawing discards everything defined in it. The
;;; helper is therefore reloaded from disk for every drawing in the run.
;;;
;;; What it does, per drawing:
;;;
;;;   1. Selects every attributed block whose name matches any pattern in the
;;;      list -- plus every anonymous "*U" block, since a dynamic block's
;;;      stored name never matches the pattern but its effective name might.
;;;
;;;   2. Groups the blocks found by which LAYOUT they are in, and processes
;;;      the layouts in TAB ORDER. That ordering is what makes the layout
;;;      counter mean "sheet 1, sheet 2, sheet 3" rather than an arbitrary
;;;      database order.
;;;
;;;   3. For each block, reads its current attribute values first -- so the
;;;      <[TAG]> operator can refer to values that later assignments will
;;;      overwrite, and still get the ORIGINAL.
;;;
;;;   4. Expands the three operators and writes the result, skipping any
;;;      attribute on a locked layer.
;;;
;;; Returns the filename, or nil if it could not be written.
;;; ---------------------------------------------------------------------------

(defun TagBatch:WriteHelper ( file / des )
    (if (setq des (open file "w"))
        (progn
            (foreach line
               '(
                    ";;; TagBatch helper - written automatically, do not edit."
                    ";;; Loaded into each drawing by the TagBatch script."
                    ""
                    "(defun TagBatch:Apply ( lst / atts cur ent idx cnt item"
                    "                              layouts names order refs sel tags val )"
                    "    (if"
                    "        (setq sel"
                    "            (ssget \"_X\""
                    "                (append"
                    "                   '("
                    "                        (000 . \"INSERT\")"
                    "                        (066 . 1)"
                    "                        (-04 . \"<OR\")"
                    "                        (002 . \"`*U*\")"
                    "                    )"
                    "                    (mapcar '(lambda ( x ) (cons 002 x)) (mapcar 'car lst))"
                    "                   '("
                    "                        (-04 . \"OR>\")"
                    "                    )"
                    "                )"
                    "            )"
                    "        )"
                    "        (progn"
                    "            ;; Layout names and their tab positions."
                    "            (vlax-for lay (vla-get-layouts"
                    "                              (vla-get-activedocument (vlax-get-acad-object)))"
                    "                (setq names (cons (strcase (vla-get-name lay)) names)"
                    "                      order (cons (vla-get-taborder lay) order)"
                    "                )"
                    "            )"
                    "            ;; Group the blocks found by layout."
                    "            (repeat (setq idx (sslength sel))"
                    "                (setq idx (1- idx)"
                    "                      ent (ssname sel idx)"
                    "                      lay (strcase (cdr (assoc 410 (entget ent))))"
                    "                )"
                    "                (if (setq item (assoc lay refs))"
                    "                    (setq refs (subst (vl-list* lay (vlax-ename->vla-object ent)"
                    "                                               (cdr item)) item refs))"
                    "                    (setq refs (cons (list lay (vlax-ename->vla-object ent)) refs))"
                    "                )"
                    "            )"
                    "            ;; TagBatch:Walk the layouts in tab order, counting as we go."
                    "            (setq cnt -1)"
                    "            (foreach idx (vl-sort-i order '<)"
                    "                (foreach obj (cdr (assoc (nth idx names) refs))"
                    "                    (if (setq bln (strcase (TagBatch:BlockName obj))"
                    "                              tags (vl-some '(lambda ( x )"
                    "                                                 (if (wcmatch bln (strcase (car x)))"
                    "                                                     (cdr x)))"
                    "                                            lst)"
                    "                        )"
                    "                        (progn"
                    "                            ;; Current values are read BEFORE anything is"
                    "                            ;; written, so <[TAG]> always sees the original."
                    "                            (setq atts (vlax-invoke obj 'getattributes)"
                    "                                  cur  (mapcar '(lambda ( a )"
                    "                                                    (cons (strcase (vla-get-tagstring a))"
                    "                                                          (vla-get-textstring a)))"
                    "                                               atts)"
                    "                            )"
                    "                            (foreach att atts"
                    "                                (if (setq val (cdr (assoc (strcase (vla-get-tagstring att))"
                    "                                                          tags)))"
                    "                                    (if (vlax-write-enabled-p att)"
                    "                                        (vla-put-textstring att"
                    "                                            (TagBatch:Operators \"<[\" \"]>\" cur"
                    "                                                (TagBatch:Operators \"<D#\" \"#D>\""
                    "                                                    (cond ((vl-bb-ref 'TagBatch:dwgcount)) (1))"
                    "                                                    (TagBatch:Operators \"<L#\" \"#L>\" cnt val)"
                    "                                                )"
                    "                                            )"
                    "                                        )"
                    "                                    )"
                    "                                )"
                    "                            )"
                    "                        )"
                    "                    )"
                    "                )"
                    "                (setq cnt (1+ cnt))"
                    "            )"
                    "        )"
                    "    )"
                    "    (princ)"
                    ")"
                    ""
                    ";;; Expands one operator wherever it appears in a string, then"
                    ";;; recurses on what is left -- so an operator can appear any number"
                    ";;; of times and the three kinds can be nested through each other."
                    ";;;"
                    ";;;   pt1, pt2 - the opening and closing markers"
                    ";;;   arg      - a number for the counting operators, or the block's"
                    ";;;              current attribute values for the <[TAG]> operator"
                    ";;;   str      - the string to expand"
                    ""
                    "(defun TagBatch:Operators ( pt1 pt2 arg str / ps1 ps2 val )"
                    "    (if"
                    "        (wcmatch (strcase str)"
                    "            (strcat \"*\""
                    "                (TagBatch:EscapeWild (strcase pt1)) \"*\""
                    "                (TagBatch:EscapeWild (strcase pt2)) \"*\""
                    "            )"
                    "        )"
                    "        (progn"
                    "            (setq ps1 (vl-string-search (strcase pt1) (strcase str))"
                    "                  ps2 (vl-string-search (strcase pt2) (strcase str))"
                    "                  val (substr str (+ 1 ps1 (strlen pt1)) (- ps2 ps1 (strlen pt1)))"
                    "            )"
                    "            (strcat"
                    "                (substr str 1 ps1)"
                    "                ;; A marker of the form <?# is a counter: add the"
                    "                ;; running count to whatever number was typed. Anything"
                    "                ;; else is a tag lookup."
                    "                (if (wcmatch pt1 \"<?`#\")"
                    "                    (if (member (type (read val)) '(int real))"
                    "                        (TagBatch:NumToStr (+ arg (read val)))"
                    "                        val"
                    "                    )"
                    "                    (cond ((cdr (assoc (strcase val) arg))) (\"\"))"
                    "                )"
                    "                (TagBatch:Operators pt1 pt2 arg (substr str (+ 1 ps2 (strlen pt2))))"
                    "            )"
                    "        )"
                    "        str"
                    "    )"
                    ")"
                    ""
                    ";;; Formats a number without a trailing decimal point when it is"
                    ";;; whole, and without trailing zeros when it is not -- so a counter"
                    ";;; produces \"7\" rather than \"7.0000\"."
                    ""
                    "(defun TagBatch:NumToStr ( num / zin out )"
                    "    (if (equal num (atoi (rtos num 2 0)) 1e-8)"
                    "        (rtos num 2 0)"
                    "        (progn"
                    "            (setq zin (getvar 'dimzin))"
                    "            (setvar 'dimzin 8)"
                    "            (setq out (rtos num 2 8))"
                    "            (setvar 'dimzin zin)"
                    "            out"
                    "        )"
                    "    )"
                    ")"
                    ""
                    ";;; Escapes every character wcmatch treats as a wildcard, so the"
                    ";;; operator markers are matched literally."
                    ""
                    "(defun TagBatch:EscapeWild ( str )"
                    "    (vl-list->string"
                    "        (apply 'append"
                    "            (mapcar"
                    "               '(lambda ( c )"
                    "                    (if (member c '(35 64 46 42 63 126 91 93 45 44))"
                    "                        (list 96 c)"
                    "                        (list c)"
                    "                    )"
                    "                )"
                    "                (vl-string->list str)"
                    "            )"
                    "        )"
                    "    )"
                    ")"
                    ""
                    ";;; Returns a block's effective name, so dynamic blocks match on the"
                    ";;; name the user sees rather than the anonymous one AutoCAD stores."
                    ";;; The property test is done once and the function then rewrites"
                    ";;; itself, removing the test from every later call."
                    ""
                    "(defun TagBatch:BlockName ( obj )"
                    "    (if (vlax-property-available-p obj 'effectivename)"
                    "        (defun TagBatch:BlockName ( obj ) (vla-get-effectivename obj))"
                    "        (defun TagBatch:BlockName ( obj ) (vla-get-name obj))"
                    "    )"
                    "    (TagBatch:BlockName obj)"
                    ")"
                    ""
                    "(vl-load-com) (princ)"
                )
                (write-line line des)
            )
            (close des)
            file
        )
    )
)

;;; ===========================================================================
;;;                      D I A L O G   D E F I N I T I O N
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:DialogText
;;;
;;; Returns the DCL as a list of lines. Kept in its own function purely so
;;; the main command reads as logic rather than as a wall of markup.
;;;
;;; The three-column list boxes use a tab stop and three single-item list
;;; boxes above them as headers -- which is the only way a DCL list box gets
;;; a header row that does not scroll with the data.
;;; ---------------------------------------------------------------------------

(defun TagBatch:DialogText ( )
   '(
        "box    : list_box { width = 34.0; height = 15.0; fixed_width = true;"
        "                    fixed_height = true; alignment = centered;"
        "                    multiple_select = true; }"
        "hdr    : list_box { width = 34.0; height = 1.0; fixed_width = true;"
        "                    fixed_height = true; alignment = centered;"
        "                    is_enabled = false; }"
        "edt    : edit_box { edit_width = 30; fixed_width = true; alignment = left; }"
        "but12  : button   { width = 12; fixed_width = true; alignment = centered; }"
        "but16  : button   { width = 16; fixed_width = true; alignment = centered; }"
        ""
        "tb_data : dialog { label = \"Tag Batch - Attribute Data\";"
        "  spacer;"
        "  : boxed_column { label = \"New Attribute Data\";"
        "    : edt { key = \"block\"; label = \"Block name (wildcards allowed):\"; }"
        "    : edt { key = \"tag\";   label = \"Attribute tag:\"; }"
        "    : edt { key = \"value\"; label = \"New value:\"; }"
        "    spacer;"
        "    : row { alignment = centered; fixed_width = true;"
        "      : but16 { key = \"additem\"; label = \"Add Item\"; }"
        "      : but16 { key = \"select\";  label = \"Select Blocks...\"; }"
        "      : but16 { key = \"delitem\"; label = \"Remove Item\"; }"
        "    }"
        "    spacer;"
        "  }"
        "  spacer;"
        "  : row { : hdr { key = \"h1\"; } : hdr { key = \"h2\"; } : hdr { key = \"h3\"; } }"
        "  : list_box { key = \"list\"; width = 104; height = 12; fixed_width = true;"
        "               fixed_height = true; alignment = centered;"
        "               multiple_select = true; tabs = \"34 68\"; tab_truncate = true; }"
        "  : text { label = \"Double-click an entry to edit it   \"; alignment = right; }"
        "  spacer;"
        "  : row { alignment = centered; fixed_width = true;"
        "    : but12 { key = \"load\";  label = \"Load...\"; }"
        "    : but12 { key = \"save\";  label = \"Save...\"; }"
        "    : but12 { key = \"clear\"; label = \"Clear\"; }"
        "  }"
        "  spacer;"
        "  : row { alignment = centered; fixed_width = true;"
        "    : but12 { key = \"accept\"; label = \"Next >\"; is_default = true; }"
        "    : but12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
        "  }"
        "}"
        ""
        "tb_files : dialog { label = \"Tag Batch - Select Drawings\";"
        "  spacer;"
        "  : row { alignment = centered;"
        "    : edit_box { key = \"directory\"; label = \"Folder:\"; edit_width = 50;"
        "                 fixed_width = true; }"
        "    : button   { key = \"browse\"; label = \"Browse\"; fixed_width = true; }"
        "  }"
        "  spacer;"
        "  : row {"
        "    : column {"
        "      : box { key = \"box1\"; }"
        "      : but16 { key = \"add\"; label = \"Add Files\"; }"
        "    }"
        "    : column { alignment = centered;"
        "      spacer;"
        "      : but12 { key = \"top\";    label = \"Top\"; }"
        "      : but12 { key = \"up\";     label = \"Up\"; }"
        "      : but12 { key = \"down\";   label = \"Down\"; }"
        "      : but12 { key = \"bottom\"; label = \"Bottom\"; }"
        "      : but12 { key = \"sort\";   label = \"Sort\"; }"
        "      spacer;"
        "    }"
        "    : column {"
        "      : box { key = \"box2\"; }"
        "      : but16 { key = \"del\"; label = \"Remove Files\"; }"
        "    }"
        "  }"
        "  : text { label = \"Drawings are processed in the order listed on the right\";"
        "           alignment = centered; }"
        "  spacer;"
        "  : row { alignment = centered; fixed_width = true;"
        "    : but12 { key = \"back\";   label = \"< Back\"; }"
        "    : but12 { key = \"accept\"; label = \"Run\"; is_default = true; }"
        "    : but12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
        "  }"
        "}"
        ""
        "tb_select : dialog { label = \"Select Attributes to Update\";"
        "  spacer;"
        "  : row { : hdr { key = \"h1\"; } : hdr { key = \"h2\"; } : hdr { key = \"h3\"; } }"
        "  : list_box { key = \"list\"; width = 104; height = 16; fixed_width = true;"
        "               fixed_height = true; alignment = centered;"
        "               multiple_select = true; tabs = \"34 68\"; tab_truncate = true; }"
        "  : toggle { key = \"all\"; label = \"Select all\"; }"
        "  spacer; ok_cancel;"
        "}"
        ""
        "tb_edit : dialog { label = \"Edit Item\";"
        "  spacer;"
        "  : edt { key = \"block\"; label = \"Block name (wildcards allowed):\"; }"
        "  : edt { key = \"tag\";   label = \"Attribute tag:\"; }"
        "  : edt { key = \"value\"; label = \"New value:\"; }"
        "  spacer; ok_cancel;"
        "}"
        ""
        "tb_confirm : dialog { key = \"ctitle\";"
        "  spacer;"
        "  : list_box { key = \"ctext\"; width = 70; height = 12; fixed_width = true;"
        "               fixed_height = true; alignment = centered; is_enabled = false; }"
        "  spacer; ok_cancel;"
        "}"
    )
)

;;; ===========================================================================
;;;                        S U B - D I A L O G S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:SelectBlocks
;;;
;;; Reads every attributed block the user selects, offers its tags and
;;; current values as a checklist, and merges what is ticked into the list.
;;;
;;; This is by far the fastest way to build a list: the tags come from the
;;; blocks themselves, so they cannot be misspelled, and the current values
;;; are pre-filled ready to be edited.
;;;
;;; Where a chosen item clashes with something already in the list, the user
;;; is shown exactly which entries would be replaced before it happens.
;;;
;;;   dch - the loaded dialog handle
;;;   lst - the existing attribute data list
;;;
;;; Returns the updated list.
;;; ---------------------------------------------------------------------------

(defun TagBatch:SelectBlocks

    ( dch lst / TB:Ssget blk dupes ent found idx items name picked sel )

    ;; A quiet ssget: prints its own prompt and silences AutoCAD's, so the
    ;; caller's message is not buried under the standard "Select objects:".
    (defun TB:Ssget ( msg filter / res )
        (setvar 'nomutt 1)
        (princ msg)
        (setq res (vl-catch-all-apply 'ssget (list filter)))
        (setvar 'nomutt 0)
        (if (and res (null (vl-catch-all-error-p res))) res)
    )

    (cond
        (   (null
                (setq sel
                    (TB:Ssget "\nSelect attributed blocks: "
                        (list '(0 . "INSERT") '(66 . 1)
                              (cons 410 (if (= 1 (getvar 'cvport))
                                            (TagBatch:EscapeWild (getvar 'ctab))
                                            "Model"))))
                )
            )
            lst
        )

        (   t
            ;; Read every attribute of every block selected.
            (setq idx (sslength sel))
            (repeat idx
                (setq ent (ssname sel (setq idx (1- idx)))
                      blk (strcase (TagBatch:EffectiveName ent))
                )
                (setq found
                    (append
                        (mapcar
                           '(lambda ( att )
                                (list blk
                                      (strcase (vla-get-tagstring att))
                                      (vla-get-textstring att))
                            )
                            (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
                        )
                        found
                    )
                )
            )

            ;; The same block and tag can appear many times over -- twenty
            ;; copies of one title block give twenty identical rows. Only one
            ;; is kept, and the user is told which were dropped.
            (setq found (TagBatch:RemoveDuplicates found))
            (if (and (cadr found)
                     (not (TagBatch:Confirm dch "Duplicate Items"
                              (strcat "The same block and tag appears more than once in "
                                      "the selection. These duplicates were removed:\n"
                                      (TagBatch:Join (cadr found) "\n")
                                      "\n\nContinue?")))
                )
                lst
                (progn
                    (setq found (car found))
                    (if (not (new_dialog "tb_select" dch))
                        (progn (alert "The selection dialog could not be displayed.") lst)
                        (progn
                            (mapcar 'TagBatch:FillList
                                   '("h1" "h2" "h3")
                                   '(("\tBlock") ("\tTag") ("\tValue")))
                            (setq found (TagBatch:ShowData "list" found))

                            ;; The Select All tick and the list stay in step
                            ;; in both directions.
                            (action_tile "list"
                                (vl-prin1-to-string
                                   '(progn
                                        (setq picked $value)
                                        (set_tile "all"
                                            (if (= (length (read (strcat "(" picked ")")))
                                                   (length found))
                                                "1" "0"))
                                    )
                                )
                            )
                            (action_tile "all"
                                (vl-prin1-to-string
                                   '(
                                        (lambda ( / n acc )
                                            (if (= "1" $value)
                                                (progn
                                                    (setq n (length found))
                                                    (repeat n
                                                        (setq acc (cons (itoa (setq n (1- n))) acc)))
                                                    (set_tile "list"
                                                        (setq picked (vl-string-trim "()"
                                                                         (vl-princ-to-string acc))))
                                                )
                                                (progn
                                                    (set_tile "list" "")
                                                    (setq picked nil)
                                                )
                                            )
                                        )
                                    )
                                )
                            )

                            (action_tile "accept"
                                (vl-prin1-to-string
                                   '(
                                        (lambda ( / clash merged )
                                            (cond
                                                (   (or (null picked) (= "" picked))
                                                    (if (TagBatch:Confirm dch "Nothing Selected"
                                                            (strcat "No items were ticked.\n\n"
                                                                    "Return to the main dialog?"))
                                                        (done_dialog 1)
                                                    )
                                                )
                                                (   (progn
                                                        (setq items (mapcar '(lambda ( n ) (nth n found))
                                                                            (read (strcat "(" picked ")"))))
                                                        ;; Merge: for every
                                                        ;; existing entry, if a
                                                        ;; newly picked one has
                                                        ;; the same block and
                                                        ;; tag, the new one
                                                        ;; wins and the old is
                                                        ;; noted as replaced.
                                                        (setq merged
                                                            (append
                                                                (mapcar
                                                                   '(lambda ( old )
                                                                        (cond
                                                                            (   (vl-some
                                                                                   '(lambda ( new )
                                                                                        (if (and (= (car  old) (car  new))
                                                                                                 (= (cadr old) (cadr new)))
                                                                                            (progn
                                                                                                (setq clash (cons (TagBatch:Join new "  |  ") clash)
                                                                                                      items (vl-remove new items))
                                                                                                new
                                                                                            )
                                                                                        )
                                                                                    )
                                                                                    items
                                                                                )
                                                                            )
                                                                            (   old)
                                                                        )
                                                                    )
                                                                    lst
                                                                )
                                                                items
                                                            )
                                                        )
                                                        (setq clash (reverse clash))
                                                    )
                                                    (if (TagBatch:Confirm dch "Item Clash"
                                                            (strcat "These items are already in the "
                                                                    "list and will be replaced:\n"
                                                                    (TagBatch:Join clash "\n")
                                                                    "\n\nContinue?"))
                                                        (progn (setq lst merged) (done_dialog 1))
                                                    )
                                                )
                                                (   t (setq lst merged) (done_dialog 1))
                                            )
                                        )
                                    )
                                )
                            )
                            (start_dialog)
                            lst
                        )
                    )
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:EditItem
;;;
;;; Edits one entry, opened by double-clicking it.
;;;
;;;   dch  - the loaded dialog handle
;;;   item - the entry to edit
;;;   lst  - the whole list, for the duplicate check
;;;
;;; Returns the list, with the entry replaced if the edit was accepted.
;;; ---------------------------------------------------------------------------

(defun TagBatch:EditItem ( dch item lst / TB:Check block tag value )

    (defun TB:Check ( / clash )
        (cond
            (   (or (null block) (= "" block))
                (alert (strcat "Enter a block name.\n\n"
                               "Block names are not case-sensitive and may use wildcards."))
                (mode_tile "block" 2)
            )
            (   (or (null tag) (= "" tag))
                (alert "Enter an attribute tag.")
                (mode_tile "tag" 2)
            )
            (   (vl-string-position 32 tag)
                (alert "An attribute tag cannot contain spaces.")
                (mode_tile "tag" 2)
            )
            ;;  The entry being edited is excluded from the duplicate check,
            ;;  so leaving the block and tag alone and changing only the value
            ;;  is allowed.
            (   (setq clash
                    (vl-some
                       '(lambda ( other )
                            (if (and (not (equal other item))
                                     (= (car  other) (strcase block))
                                     (= (cadr other) (strcase tag))
                                )
                                other
                            )
                        )
                        lst
                    )
                )
                (alert (strcat "The tag \"" (cadr clash) "\" in block \"" (car clash)
                               "\" is already in the list."))
                (mode_tile "block" 2)
            )
            (   t (done_dialog 1))
        )
    )

    (if (not (new_dialog "tb_edit" dch))
        (progn (alert "The edit dialog could not be displayed.") lst)
        (progn
            ;; The tile key and the variable name are the same string, so one
            ;; loop both fills the tile and captures its starting value.
            (mapcar
               '(lambda ( key val ) (set (read key) (set_tile key val)))
               '("block" "tag" "value")
                item
            )
            (action_tile "block"
                (vl-prin1-to-string
                   '(progn (setq block $value) (if (= 1 $reason) (mode_tile "tag" 2))))
            )
            (action_tile "tag"
                (vl-prin1-to-string
                   '(progn (setq tag $value) (if (= 1 $reason) (mode_tile "value" 2))))
            )
            (action_tile "value"
                (vl-prin1-to-string
                   '(progn (setq value $value) (if (= 1 $reason) (TB:Check))))
            )
            (action_tile "accept" "(TB:Check)")
            (if (= 1 (start_dialog))
                (subst (list (strcase block) (strcase tag) value) item lst)
                lst
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:Confirm
;;;
;;; A yes/no question, for the file-scope functions that need one.
;;; ---------------------------------------------------------------------------

(defun TagBatch:Confirm ( dch title msg / ok )
    (if (not (new_dialog "tb_confirm" dch))
        nil
        (progn
            (set_tile "ctitle" title)
            (start_list "ctext")
            (foreach line (TagBatch:Split msg "\n") (add_list line))
            (end_list)
            (action_tile "accept" "(setq ok t) (done_dialog)")
            (action_tile "cancel" "(done_dialog)")
            (start_dialog)
            ok
        )
    )
)

;;; ===========================================================================
;;;                    L O A D   A N D   S A V E
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:SaveToFile
;;;
;;; Writes the attribute list to a CSV or tab-separated text file, so a list
;;; built once can be reused on the next project.
;;;
;;; The format follows the extension: .txt is tab separated, anything else is
;;; proper CSV with quoting where a value contains a comma or a quote.
;;; ---------------------------------------------------------------------------

(defun TagBatch:SaveToFile ( data / des name )
    (cond
        (   (null data) nil)
        (   (null (setq name (getfiled "Create output file" "" "csv;txt" 1))) nil)
        (   (null (setq des (open name "w")))
            (alert (strcat "The file could not be opened for writing:\n\n" name
                           "\n\nCheck that you have write permission for that folder."))
            nil
        )
        (   t
            (if (= ".TXT" (strcase (vl-filename-extension name)))
                (foreach item data (write-line (TagBatch:Join item "\t") des))
                (foreach item data (write-line (TagBatch:RowToCsv item) des))
            )
            (close des)
            (alert (strcat "Attribute data saved to:\n\n" name))
            t
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:LoadFromFile
;;;
;;; Reads an attribute list from a CSV or tab-separated file.
;;;
;;; The file is validated as it is read. Rows are rejected if they have fewer
;;; than two columns, if the block or tag is blank, or if the tag contains a
;;; space -- which AutoCAD does not permit. Everything rejected is listed, so
;;; a spreadsheet with a header row or a stray blank line reports exactly
;;; what it dropped rather than failing silently.
;;;
;;; Duplicate block-and-tag pairs are also found and reported.
;;;
;;; Returns the list, or nil.
;;; ---------------------------------------------------------------------------

(defun TagBatch:LoadFromFile ( dch / data des dupes line name rejected )
    (cond
        (   (null (setq name (getfiled "Select file to load" "" "csv;txt" 16))) nil)
        (   (null (setq des (open name "r")))
            (alert (strcat "The file could not be opened for reading:\n\n" name))
            nil
        )
        (   t
            (if (= ".TXT" (strcase (vl-filename-extension name)))
                (while (setq line (read-line des))
                    (setq data (cons (TagBatch:Split line "\t") data)))
                (while (setq line (read-line des))
                    (setq data (cons (TagBatch:CsvToRow line 0) data)))
            )
            (close des)
            (setq data (reverse data))

            (cond
                (   (null data)
                    (alert "That file contained no data.")
                    nil
                )
                (   (null
                        (setq data
                            (apply 'append
                                (mapcar
                                   '(lambda ( row )
                                        (if (or (< (length row) 2)
                                                (= "" (car  row))
                                                (= "" (cadr row))
                                                (vl-string-position 32 (cadr row))
                                            )
                                            (progn
                                                (setq rejected
                                                    (cons (TagBatch:Join row "  |  ") rejected))
                                                nil
                                            )
                                            ;; Wrapped in a list so the
                                            ;; rejected rows can contribute
                                            ;; nothing when appended.
                                            (list (list (strcase (car  row))
                                                        (strcase (cadr row))
                                                        (cond ((caddr row)) (""))))
                                        )
                                    )
                                    data
                                )
                            )
                        )
                    )
                    (alert (strcat
                        "That file is not in the format this program expects.\n\n"
                        "It needs three columns: block, tag and value. A text file "
                        "must be tab separated.\n\nTags cannot contain spaces."))
                    nil
                )
                (   t
                    (setq dupes    (TagBatch:RemoveDuplicates data)
                          rejected (reverse rejected)
                    )
                    (cond
                        ;;  Report rejected rows first, then duplicates. Both
                        ;;  are answerable with no, which abandons the load.
                        (   (and rejected
                                 (not (TagBatch:Confirm dch "Items Removed"
                                          (strcat "These rows were skipped because the block "
                                                  "or tag was missing, or the tag contained "
                                                  "a space:\n"
                                                  (TagBatch:Join rejected "\n")
                                                  "\n\nContinue?"))))
                            nil
                        )
                        (   (and (cadr dupes)
                                 (not (TagBatch:Confirm dch "Duplicate Items"
                                          (strcat "The same block and tag appears more than "
                                                  "once. These duplicates were removed:\n"
                                                  (TagBatch:Join (cadr dupes) "\n")
                                                  "\n\nContinue?"))))
                            nil
                        )
                        (   (car dupes))
                    )
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:WriteConfig / TagBatch:ReadConfig
;;;
;;; Save and reload the whole session: the attribute list, the folder, and
;;; the drawings chosen.
;;;
;;; The file is written as three tagged sections rather than as printed LISP,
;;; so it can be read and edited by hand.
;;; ---------------------------------------------------------------------------

(defun TagBatch:WriteConfig ( cfg data dir files / des )
    (if (setq des (open cfg "w"))
        (progn
            (write-line "[DATA]" des)
            (foreach item data (write-line (TagBatch:Join item "\t") des))
            (write-line "[FOLDER]" des)
            (if dir (write-line dir des))
            (write-line "[FILES]" des)
            (foreach f files (write-line f des))
            (close des)
            t
        )
    )
)

(defun TagBatch:ReadConfig ( cfg / data des dir files line mode )
    (if (and (setq cfg (findfile cfg))
             (setq des (open cfg "r"))
        )
        (progn
            (while (setq line (read-line des))
                (cond
                    (   (= "[DATA]"   line) (setq mode 'data))
                    (   (= "[FOLDER]" line) (setq mode 'dir))
                    (   (= "[FILES]"  line) (setq mode 'files))
                    (   (= "" line))
                    ;;  A data row needs all three columns; a short one is
                    ;;  from a hand-edited file and is skipped.
                    (   (= 'data mode)
                        (   (lambda ( row )
                                (if (= 3 (length row)) (setq data (cons row data)))
                            )
                            (TagBatch:Split line "\t")
                        )
                    )
                    (   (= 'dir   mode) (setq dir line))
                    ;;  A file that has since been deleted or moved is
                    ;;  dropped rather than offered.
                    (   (= 'files mode)
                        (if (findfile line) (setq files (cons line files)))
                    )
                )
            )
            (close des)
            (list (reverse data) dir (reverse files))
        )
    )
)

;;; ===========================================================================
;;;                    F I L E   B R O W S E R
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:ShowFolder / TagBatch:ShowChosen
;;;
;;; Refresh the two file panes. ShowChosen displays shortened relative paths
;;; but returns the untouched full paths, so the display never corrupts the
;;; data.
;;; ---------------------------------------------------------------------------

(defun TagBatch:ShowFolder ( dir files )
    (TagBatch:FillList "box1" (TagBatch:ListFolder dir files))
)

(defun TagBatch:ShowChosen ( dir files )
    (TagBatch:FillList "box2"
        (mapcar '(lambda ( f ) (TagBatch:Relative dir f)) files))
    files
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:ListFolder
;;;
;;; Returns the displayable contents of a folder: sub-folders first, then
;;; drawings, with anything already chosen filtered out so it cannot be added
;;; twice.
;;; ---------------------------------------------------------------------------

(defun TagBatch:ListFolder ( dir chosen )
    (vl-remove-if '(lambda ( f ) (member (strcat dir "\\" f) chosen))
        (append
            ;; "." is meaningless; ".." is kept because it is how the user
            ;; navigates upwards.
            (TagBatch:FileSort (vl-remove "." (vl-directory-files dir nil -1)))
            (TagBatch:FileSort (vl-directory-files dir "*.dwg" 1))
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:ButtonModes
;;;
;;; Returns the enable/disable state for the five reorder buttons, in the
;;; order Top, Up, Down, Bottom, Sort. Zero enables, one disables.
;;;
;;; The logic is: nothing selected or an empty list disables everything but
;;; Sort; a selection already at the very top cannot move up; one already at
;;; the very bottom cannot move down; selecting everything makes reordering
;;; meaningless.
;;;
;;; Doing this properly rather than leaving the buttons always live is what
;;; stops the highlight jumping unexpectedly when a move does nothing.
;;; ---------------------------------------------------------------------------

(defun TagBatch:ButtonModes ( idx lst / run )

    ;; A run of n consecutive numbers ending just below b -- which is what a
    ;; contiguous selection at one end of the list looks like.
    (setq run (lambda ( n b / out ) (repeat n (setq out (cons (setq b (1- b)) out)))))

    (cond
        (   (null lst)                                    '(1 1 1 1 1))
        (   (or (null idx) (= (length idx) (length lst)))  '(1 1 1 1 0))
        ;;  Already at the top: only Down and Bottom are useful.
        (   (equal idx (run (length idx) (length idx)))    '(1 1 0 0 0))
        ;;  Already at the bottom: only Top and Up are useful.
        (   (equal idx (run (length idx) (length lst)))    '(0 0 1 1 0))
        (                                                  '(0 0 0 0 0))
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:ListUp / ListDown / ListTop / ListBottom
;;;
;;; Move the items at the given positions, and return BOTH the new order and
;;; the new positions of the moved items -- which is what lets the dialog keep
;;; them highlighted so the buttons can be pressed repeatedly.
;;;
;;; ListUp walks the list once from the front. At each step, position 0 in
;;; the remaining indices means this item is selected but already at the top
;;; of what is left, so it stays; position 1 means the item after this one is
;;; selected, so the two swap; anything else passes through. Every index is
;;; decremented as the TagBatch:Walk advances, so they stay relative to the part still
;;; to be processed -- which is what makes a block of adjacent selected items
;;; move as a block rather than collapsing together.
;;;
;;; ListDown is ListUp on a reversed list with mirrored indices, which avoids
;;; writing and maintaining a second copy of that tricky logic.
;;;
;;; Each returns (new-indices new-list).
;;; ---------------------------------------------------------------------------

(defun TagBatch:ListUp ( idx lst / TagBatch:Walk )
    (defun TagBatch:Walk ( n idx lst idxout lstout )
        (cond
            (   (not (and idx lst))
                (list (reverse idxout) (append (reverse lstout) lst))
            )
            (   (= 0 (car idx))
                (TagBatch:Walk (1+ n) (mapcar '1- (cdr idx)) (cdr lst)
                      (cons n idxout) (cons (car lst) lstout))
            )
            (   (= 1 (car idx))
                (TagBatch:Walk (1+ n) (mapcar '1- (cdr idx)) (cons (car lst) (cddr lst))
                      (cons n idxout) (cons (cadr lst) lstout))
            )
            (   (TagBatch:Walk (1+ n) (mapcar '1- idx) (cdr lst) idxout (cons (car lst) lstout)))
        )
    )
    (TagBatch:Walk 0 idx lst nil nil)
)

(defun TagBatch:ListDown ( idx lst / flip mirror len )
    (setq len    (length lst)
          mirror (lambda ( n ) (- len n 1))
          flip   (lambda ( a b ) (list (reverse (mapcar 'mirror a)) (reverse b)))
    )
    (apply 'flip (apply 'TagBatch:ListUp (flip idx lst)))
)

(defun TagBatch:ListTop ( idx lst / n )
    (setq n -1)
    (list
        (mapcar '(lambda ( x ) (setq n (1+ n))) idx)
        (append (mapcar '(lambda ( x ) (nth x lst)) idx) (TagBatch:RemoveNth idx lst))
    )
)

(defun TagBatch:ListBottom ( idx lst / n )
    (setq n (length lst))
    (list
        (reverse (mapcar '(lambda ( x ) (setq n (1- n))) idx))
        (append (TagBatch:RemoveNth idx lst) (mapcar '(lambda ( x ) (nth x lst)) idx))
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:FileSort
;;;
;;; Sorts file names so that embedded numbers compare as numbers.
;;;
;;; A plain alphabetic sort gives Sheet1, Sheet10, Sheet2. Splitting each name
;;; into alternating text and numeric runs and comparing those in step gives
;;; Sheet1, Sheet2, Sheet10 -- which is the order the drawings should be
;;; processed in, because that is the order the sheet counter will number
;;; them.
;;; ---------------------------------------------------------------------------

(defun TagBatch:FileSort ( lst )
    (mapcar '(lambda ( n ) (nth n lst))
        (vl-sort-i (mapcar 'TagBatch:SplitName lst)
           '(lambda ( a b / x y )
                (while (and (setq x (car a)) (setq y (car b)) (= x y))
                    (setq a (cdr a)
                          b (cdr b)
                    )
                )
                (cond
                    (   (null x) (if y t nil))                 ;; a is shorter
                    (   (null y) nil)                          ;; b is shorter
                    (   (and (numberp x) (numberp y)) (< x y))
                    (   (numberp x))                           ;; numbers before text
                    (   (numberp y) nil)
                    (   (< x y))
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:SplitName
;;;
;;; Splits a string into alternating text and numeric pieces, for the natural
;;; sort above. "Sheet10a" becomes ("S" "H" ... 10 "A").
;;;
;;; The string is processed one character at a time: hyphen, full stop and
;;; backslash become separators; digits are emitted bare so consecutive
;;; digits fuse into one number when the result is read back; anything else
;;; is emitted as a quoted one-character string.
;;;
;;; Building a source string and handing it to read is far faster in AutoLISP
;;; than assembling the list by hand.
;;; ---------------------------------------------------------------------------

(defun TagBatch:SplitName ( str )
    (   (lambda ( chars )
            (read
                (strcat "("
                    (vl-list->string
                        (apply 'append
                            (mapcar
                               '(lambda ( prev this next )
                                    (cond
                                        (   (member this '(45 46 92)) (list 32))
                                        (   (< 47 this 58)            (list this))
                                        (   (list 32 34 this 34 32))
                                    )
                                )
                                ;; Three parallel lists give each character its
                                ;; neighbours, which mapcar needs to run in step.
                                (cons nil chars) chars (append (cdr chars) '(()))
                            )
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list (strcase str))
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:Redirect
;;;
;;; Resolves the legacy junction folders Windows keeps under the user
;;; profile. "My Documents" and friends still appear in directory listings
;;; but are junction points that cannot be listed directly; the real folder
;;; has the shorter modern name.
;;;
;;; Without this, double-clicking "My Documents" opens an empty folder.
;;; ---------------------------------------------------------------------------

(defun TagBatch:Redirect ( dir / itm pos )
    (cond
        (   (vl-directory-files dir) dir)
        (   (and
                (= (strcase (getenv "UserProfile"))
                   (strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t)))))
                (setq itm
                    (cdr (assoc (substr (strcase dir t) (+ pos 2))
                           '(("my documents" . "Documents")
                             ("my pictures"  . "Pictures")
                             ("my videos"    . "Videos")
                             ("my music"     . "Music"))))
                )
                (vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
            )
            itm
        )
        (   dir)
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:Relative
;;;
;;; Converts a full path to one relative to the given folder, purely so the
;;; chosen-files list stays readable. Showing thirty identical long paths
;;; would hide the only part that differs -- the file name.
;;; ---------------------------------------------------------------------------

(defun TagBatch:Relative ( dir path / p q )
    (setq dir (vl-string-right-trim "\\" dir))
    (cond
        ;;  Different drives: no relative form exists.
        (   (and (setq p (vl-string-position 58 dir))
                 (setq q (vl-string-position 58 path))
                 (/= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            path
        )
        ;;  Shared leading folder: strip it and recurse.
        (   (and (setq p (vl-string-position 92 dir))
                 (setq q (vl-string-position 92 path))
                 (= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            (TagBatch:Relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
        )
        (   (and (setq q (vl-string-position 92 path))
                 (= (strcase dir) (strcase (substr path 1 q)))
            )
            (strcat ".\\" (substr path (+ 2 q)))
        )
        (   (= "" dir) path)
        (   (setq p (vl-string-position 92 dir))
            (TagBatch:Relative (substr dir (+ 2 p)) (strcat "..\\" path))
        )
        (   (TagBatch:Relative "" (strcat "..\\" path)))
    )
)

(defun TagBatch:UpDir ( dir )
    (substr dir 1 (vl-string-position 92 dir nil t))
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:CheckLocks
;;;
;;; Separates the drawings that can be processed from those that are open
;;; elsewhere.
;;;
;;; AutoCAD writes a .dwl file alongside any drawing it has open, holding the
;;; name of whoever opened it. If that file can be DELETED, nobody has the
;;; drawing open -- so the delete doubles as the test. AutoCAD recreates it
;;; the moment the drawing is next opened.
;;;
;;; Checking now rather than discovering it half way through a run is what
;;; stops a batch stopping ten drawings in with a modal prompt nobody is
;;; watching for.
;;;
;;; Returns (usable-paths locked-descriptions).
;;; ---------------------------------------------------------------------------

(defun TagBatch:CheckLocks ( files / dwl locked usable who )
    (foreach file files
        (setq dwl (findfile (strcat (substr file 1 (- (strlen file) 3)) "dwl")))
        (if (and dwl (null (vl-file-delete dwl)))
            (progn
                ;; The first line of the lock file is the user who has it
                ;; open, which is far more useful than "in use".
                (setq who
                    (   (lambda ( / des name )
                            (if (setq des (open dwl "r"))
                                (progn (setq name (read-line des)) (close des) name)
                                "<unknown>"
                            )
                        )
                    )
                )
                (setq locked (cons (strcat (vl-filename-base file) ".dwg   -   open by "
                                           (cond (who) ("<unknown>")))
                                   locked))
            )
            (setq usable (cons file usable))
        )
    )
    (list (reverse usable) (reverse locked))
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:PickFolder
;;;
;;; The native Windows folder picker. Two COM objects are created and both
;;; must be released explicitly; the releases sit outside the catch so they
;;; happen even when the picker fails.
;;; ---------------------------------------------------------------------------

(defun TagBatch:PickFolder ( msg dir flg / err fold path self shell )
    (setq err
        (vl-catch-all-apply
           '(lambda ( / app hwnd )
                (setq app   (vlax-get-acad-object)
                      shell (vla-getinterfaceobject app "Shell.Application")
                      hwnd  (vl-catch-all-apply 'vla-get-hwnd (list app))
                      fold  (vlax-invoke-method shell 'browseforfolder
                                (if (vl-catch-all-error-p hwnd) 0 hwnd) msg flg dir)
                )
                (if fold
                    (setq self (vlax-get-property fold 'self)
                          path (TagBatch:FixDir (vlax-get-property self 'path))
                    )
                )
            )
        )
    )
    (if self  (vlax-release-object self))
    (if fold  (vlax-release-object fold))
    (if shell (vlax-release-object shell))
    (if (vl-catch-all-error-p err) nil path)
)

;;; ===========================================================================
;;;                    S M A L L   U T I L I T I E S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TagBatch:FillList
;;;
;;; Loads a list box tile.
;;; ---------------------------------------------------------------------------

(defun TagBatch:FillList ( key lst )
    (start_list key)
    (foreach x lst (add_list x))
    (end_list)
    lst
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:ShowData
;;;
;;; Fills the three-column attribute list and returns the data, sorted by
;;; block name and then by tag -- so entries for one block stay together and
;;; the list stays predictable however it was built.
;;; ---------------------------------------------------------------------------

(defun TagBatch:ShowData ( key data )
    (setq data
        (vl-sort data
           '(lambda ( a b )
                (if (= (car a) (car b))
                    (< (cadr a) (cadr b))
                    (< (car  a) (car  b))
                )
            )
        )
    )
    (start_list key)
    (foreach item data (add_list (TagBatch:Join item "\t")))
    (end_list)
    data
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:RemoveDuplicates
;;;
;;; Removes entries whose block and tag both match an earlier one, keeping
;;; the first of each.
;;;
;;; Returns (kept removed) so the caller can report exactly what was dropped
;;; rather than silently discarding it.
;;; ---------------------------------------------------------------------------

(defun TagBatch:RemoveDuplicates ( lst / dropped kept )
    (while lst
        (setq kept (cons (car lst) kept))
        (setq lst
            (vl-remove-if
               '(lambda ( x )
                    (if (and (= (caar  lst) (car  x))
                             (= (cadar lst) (cadr x))
                        )
                        (setq dropped (cons (TagBatch:Join x "  |  ") dropped))
                    )
                )
                (cdr lst)
            )
        )
    )
    (list (reverse kept) (reverse dropped))
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:GroupByBlock
;;;
;;; Regroups the flat list of (block tag value) into
;;; (block (tag . value) (tag . value) ...) per block.
;;;
;;; That is the shape the helper needs: it matches a block once and then
;;; looks its tags up directly, rather than scanning the whole list for every
;;; attribute of every block in every drawing.
;;; ---------------------------------------------------------------------------

(defun TagBatch:GroupByBlock ( lst / found out )
    (foreach item lst
        (if (setq found (assoc (car item) out))
            (setq out (subst (cons (car found)
                                   (cons (cons (cadr item) (caddr item)) (cdr found)))
                             found out))
            (setq out (cons (list (car item) (cons (cadr item) (caddr item))) out))
        )
    )
    out
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:RemoveNth
;;;
;;; Removes items by POSITION rather than by value, since two entries can
;;; legitimately share a name.
;;; ---------------------------------------------------------------------------

(defun TagBatch:RemoveNth ( idxs lst / n )
    (setq n -1)
    (vl-remove-if '(lambda ( x ) (vl-position (setq n (1+ n)) idxs)) lst)
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:Join / TagBatch:Split
;;;
;;; Join a list of strings with a separator, and split a string on one.
;;; ---------------------------------------------------------------------------

(defun TagBatch:Join ( lst del / out )
    (setq out (car lst))
    (foreach x (cdr lst) (setq out (strcat out del x)))
    out
)

(defun TagBatch:Split ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos)
              (TagBatch:Split (substr str (+ pos 1 (strlen del))) del))
        (list str)
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:RowToCsv / TagBatch:CsvToRow
;;;
;;; Convert one row of values to and from CSV.
;;;
;;; A value is quoted if it contains a comma or a quote, and quotes inside it
;;; are doubled -- the standard rules. Without that, a value containing a
;;; comma would split into two columns and shift everything after it.
;;;
;;; Reading is a character-by-character TagBatch:Walk rather than a split, because a
;;; comma inside quotes is data, not a separator.
;;; ---------------------------------------------------------------------------

(defun TagBatch:RowToCsv ( lst )
    (if (cdr lst)
        (strcat (TagBatch:AddQuotes (car lst)) "," (TagBatch:RowToCsv (cdr lst)))
        (TagBatch:AddQuotes (car lst))
    )
)

(defun TagBatch:AddQuotes ( str / pos )
    (cond
        (   (wcmatch str "*[`,\"]*")
            (setq pos 0)
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str)
    )
)

(defun TagBatch:CsvToRow ( str pos / s )
    (cond
        (   (null (setq s (vl-string-position 44 str pos)))
            (list (TagBatch:StripQuotes (substr str (1+ pos))))
        )
        ;;  A field starting with a quote runs to its matching close quote,
        ;;  so any comma inside it is part of the value.
        (   (and (= 34 (ascii (substr str (1+ pos) 1)))
                 (setq s (TagBatch:CloseQuote str (1+ pos)))
            )
            (cons (TagBatch:StripQuotes (substr str (1+ pos) (- s pos)))
                  (TagBatch:CsvToRow str (1+ s)))
        )
        (   (cons (TagBatch:StripQuotes (substr str (1+ pos) (- s pos)))
                  (TagBatch:CsvToRow str (1+ s)))
        )
    )
)

;;; Finds the position of the quote that closes a quoted field, skipping over
;;; doubled quotes, which represent a literal quote inside the value.
(defun TagBatch:CloseQuote ( str pos / at )
    (setq at (vl-string-position 34 str pos))
    (cond
        (   (null at) nil)
        (   (= 34 (ascii (substr str (+ 2 at) 1)))
            (TagBatch:CloseQuote str (+ 2 at))
        )
        (   (1+ at))
    )
)

;;; Removes the surrounding quotes from a field and un-doubles any quotes
;;; inside it.
(defun TagBatch:StripQuotes ( str / pos )
    (if (and (< 1 (strlen str))
             (= 34 (ascii (substr str 1 1)))
             (= 34 (ascii (substr str (strlen str) 1)))
        )
        (progn
            (setq str (substr str 2 (- (strlen str) 2))
                  pos 0
            )
            (while (setq pos (vl-string-search "\"\"" str pos))
                (setq str (vl-string-subst "\"" "\"\"" str pos)
                      pos (1+ pos)
                )
            )
        )
    )
    str
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:EscapeWild
;;;
;;; Escapes every character ssget's filter syntax treats as a wildcard, by
;;; preceding it with a backquote.
;;;
;;; Without this a layout genuinely named "Sheet 1*" would match far more
;;; than intended, and one named "A,B" would be read as two names.
;;; ---------------------------------------------------------------------------

(defun TagBatch:EscapeWild ( str )
    (vl-list->string
        (apply 'append
            (mapcar
               '(lambda ( c )
                    (if (member c '(35 64 46 42 63 126 91 93 45 44))
                        (list 96 c)     ;; 96 is the backquote
                        (list c)
                    )
                )
                (vl-string->list str)
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TagBatch:EffectiveName
;;;
;;; Returns the name a block shows in the user interface, given its entity
;;; name. A dynamic block whose parameters have been changed is stored under
;;; an anonymous name such as "*U27"; EffectiveName is the one the user
;;; recognises.
;;; ---------------------------------------------------------------------------

(defun TagBatch:EffectiveName ( ent / obj )
    (setq obj (vlax-ename->vla-object ent))
    (if (vlax-property-available-p obj 'effectivename)
        (vla-get-effectivename obj)
        (vla-get-name obj)
    )
)

(princ "\nTagBatch loaded. Type TAGBATCH to set attribute values across many drawings.")
(princ)

;;; ---------------------------------------------------------------------------
;;; End of file
;;; ---------------------------------------------------------------------------