;;; ---------------------------------------------------------------------------
;;; AttHarvest.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; EXTRACT AND EDIT BLOCK ATTRIBUTES ACROSS A FOLDER OF DRAWINGS
;;;
;;; Two commands sharing one engine:
;;;
;;;   ATTPULL  reads attribute values out of every drawing in a folder and
;;;            builds an Excel workbook from them.
;;;
;;;   ATTPUSH  writes new attribute values into every drawing in a folder.
;;;
;;; No drawing is opened in the editor. A hundred files are processed in the
;;; time it takes to open one.
;;;
;;; This is the door schedule pulled straight from the door blocks, the room
;;; data sheet built from the room tags, the revision number pushed into
;;; every title block on the project at once.
;;;
;;; ---------------------------------------------------------------------------
;;; ATTPULL -- EXTRACTING
;;;
;;; Name the blocks you want, either by typing the name or by picking one on
;;; screen, and choose which of their tags to extract -- all of them, or a
;;; specific list in a specific order.
;;;
;;; The result opens in Excel in one of three layouts:
;;;
;;;   GROUP BY FILENAME   one section per drawing, with each block listed
;;;                       under it and its tag values in columns. Best for
;;;                       reviewing drawings one at a time.
;;;
;;;   GROUP BY BLOCK      the same data merged across every drawing and
;;;                       grouped by block name instead. Best for counting
;;;                       and comparing one symbol across a project.
;;;
;;;   DRAWING LIST MODE   a single flat table, one column per tag and one row
;;;                       per block found, with the source drawing in its own
;;;                       column. This is the one to use if the result is
;;;                       going to be sorted, filtered or pivoted -- it is a
;;;                       proper database table.
;;;
;;; Block insertion coordinates can be included as an extra column, which
;;; turns the extract into a setting-out schedule.
;;;
;;; ---------------------------------------------------------------------------
;;; ATTPUSH -- EDITING
;;;
;;; Name one block, list the tags to change and the value each should be set
;;; to, and every matching block in every drawing is updated.
;;;
;;; Tags and their current values can be read straight off a block on screen,
;;; so building the list is a matter of picking rather than typing.
;;;
;;; When a value changes length, single-line attributes are re-anchored so
;;; centred and right-justified text stays visually where it was rather than
;;; drifting sideways.
;;;
;;; Drawings are only saved if something actually changed in them, so a run
;;; that matches nothing leaves every file's timestamp alone.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW IT WORKS
;;;
;;; Drawings are read and written through ObjectDBX -- a database-only
;;; interface with no editor window, no regen and no view to set up.
;;;
;;; A drawing already open in this AutoCAD session is handled through its
;;; live document object instead. ObjectDBX on an already-open file would
;;; read the version on disk, silently ignoring unsaved work, and would hold
;;; a second handle on a file the user is editing.
;;;
;;; Both constant and ordinary attributes are read. Constant attributes live
;;; in the block definition rather than the insertion, and are easy to miss
;;; -- a schedule that omits them is quietly incomplete.
;;;
;;; ---------------------------------------------------------------------------
;;; IMPORTANT -- READ BEFORE RUNNING ATTPUSH
;;;
;;; ATTPUSH modifies drawings and SAVES them without opening them, and there
;;; is no undo across files. Test on a copy of the folder first. Every time.
;;;
;;; ATTPULL only reads, and is safe to run on anything.
;;;
;;; Extraction requires Microsoft Excel to be installed.
;;;
;;; ---------------------------------------------------------------------------
;;;   ATTHARVEST - asks which mode, then runs it
;;;   ATTPULL    - extract attribute values to Excel
;;;   ATTPUSH    - write attribute values into drawings
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; Commands.
;;; ---------------------------------------------------------------------------

(defun c:AttPull nil (AttHarvest:Run  t ) (princ))
(defun c:AttPush nil (AttHarvest:Run nil) (princ))

(defun c:AttHarvest ( / *error* )
    (defun *error* ( msg )
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** ATTHARVEST error: " msg " **"))
        )
        (princ)
    )
    (initget "Pull Push")
    (if (= "Push" (getkword "\nAttribute [Pull/Push] <Pull>: "))
        (AttHarvest:Run nil)
        (AttHarvest:Run t)
    )
    (princ)
)

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

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

;;; ---------------------------------------------------------------------------
;;; AttHarvest:SavePath
;;;
;;; Where the settings file lives. The chain always succeeds, so nothing has
;;; to treat "nowhere to write" as a failure.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; AttHarvest:BlockName
;;;
;;; Returns the name a block shows in the user interface.
;;;
;;; A dynamic block whose parameters have been changed is stored under an
;;; anonymous name such as "*U27"; EffectiveName is the one the user
;;; recognises and the one a schedule must group by. That property does not
;;; exist in very old releases, so it is tested for.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:BlockName ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (vla-get-effectivename obj)
        (vla-get-name obj)
    )
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:AllAttributes
;;;
;;; Returns every attribute of a block reference: the ordinary ones, which
;;; belong to the insertion, and the constant ones, which live in the block
;;; definition.
;;;
;;; Constant attributes are easy to overlook -- they cannot be selected or
;;; edited individually and do not appear in the attribute editor -- but they
;;; carry real information, and a schedule that omits them is quietly
;;; incomplete.
;;;
;;; The constant call is caught because it does not exist in older releases.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:AllAttributes ( obj / res )
    (append
        (vlax-invoke obj 'getattributes)
        (progn
            (setq res (vl-catch-all-apply 'vlax-invoke (list obj 'getconstantattributes)))
            (if (vl-catch-all-error-p res) nil res)
        )
    )
)

;;; ===========================================================================
;;; AttHarvest:Run
;;;
;;; The engine behind both commands.
;;;
;;;   pull - T to extract to Excel, nil to write values into drawings
;;; ===========================================================================

(defun AttHarvest:Run

    ( pull /

        ;; ---- nested helper functions ----
        *error* AH:Restore AH:FillList AH:ShowBlocks AH:ShowTags AH:ShowPath
        AH:FolderMode AH:ChooseTags AH:ChooseTagsB AH:EditTag AH:Options
        AH:NewInsPoint

        ;; ---- settings, held in the configuration file ----
        AH:Sub AH:Blocks AH:Path AH:Cur AH:Group AH:Coords
        AH:ESub AH:Tags AH:EPath AH:ECur AH:EBlock

        ;; ---- working variables ----
        acapp acdoc allatts blkname blkstr blocks cfg changed dbx dch dcl
        des doc docs dwgs flag found idx item items lst names newtag newval
        opened progress ptr rows saved sel tagstr taglst tmp vals vars
        xlapp xlcells
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; AH:Restore
    ;;;
    ;;; Closes the progress bar, releases every COM object, unloads the dialog
    ;;; and deletes its temporary file.
    ;;;
    ;;; The Excel objects are released but Excel itself is deliberately left
    ;;; running and visible -- the workbook it holds is the result of the
    ;;; command.
    ;;; -----------------------------------------------------------------------

    (defun AH:Restore ( )
        (if progress (vl-catch-all-apply 'acet-ui-progress))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (foreach obj (list dbx xlcells xlapp)
            (if (and obj (= 'vla-object (type obj)) (not (vlax-object-released-p obj)))
                (vl-catch-all-apply 'vlax-release-object (list obj))
            )
        )
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (vla-endundomark acdoc)
        )
        (mapcar 'setvar vars vals)
        ;; Two collections: a COM object is only truly released once nothing
        ;; refers to it, and a single pass often leaves one behind.
        (gc) (gc)
        (princ)
    )

    (defun *error* ( msg )
        (AH:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** " (if pull "ATTPULL" "ATTPUSH") " error: " msg " **"))
        )
        (princ)
    )

    ;;; -----------------------------------------------------------------------
    ;;; Dialog helpers.
    ;;; -----------------------------------------------------------------------

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

    ;; The block list: name in the first column, the chosen tags in the
    ;; second, separated by a tab that the list box turns into a column.
    ;; "ALL TAGS" is shown when no specific tags were chosen.
    (defun AH:ShowBlocks ( key lst )
        (start_list key)
        (foreach pair lst
            (add_list
                (strcat
                    (if (< 29 (strlen (car pair)))
                        (strcat (substr (car pair) 1 26) "...")
                        (car pair)
                    )
                    "\t"
                    (if (cdr pair) (AttHarvest:Join (cdr pair) ",") "ALL TAGS")
                )
            )
        )
        (end_list)
        lst
    )

    ;; The tag list for the editor: tag in the first column, the value it
    ;; will be set to in the second.
    (defun AH:ShowTags ( key lst )
        (start_list key)
        (foreach pair lst
            (add_list
                (strcat
                    (if (< 29 (strlen (car pair)))
                        (strcat (substr (car pair) 1 26) "...")
                        (car pair)
                    )
                    "\t"
                    (cond ((cdr pair)) ("- NO VALUE -"))
                )
            )
        )
        (end_list)
        lst
    )

    ;; Shows a path, shortened with an ellipsis if it is too long for the
    ;; tile. Without this a deep network path runs off the edge of the dialog
    ;; and the useful end of it is invisible.
    (defun AH:ShowPath ( key str )
        (set_tile key
            (cond
                (   (null str) "")
                (   (< 45 (strlen str)) (strcat (substr str 1 42) "..."))
                (   str)
            )
        )
    )

    ;; Greys the folder controls when only the current drawing is the target.
    (defun AH:FolderMode ( val )
        (foreach key '("sub_dir" "dir" "dir_text") (mode_tile key (atoi val)))
        val
    )

    ;;; -----------------------------------------------------------------------
    ;;; AH:ChooseTags
    ;;;
    ;;; The tag chooser: builds an ordered list of tag names to extract.
    ;;;
    ;;; The ORDER matters. In the Excel output the tags become columns in the
    ;;; order they appear here, so a schedule can be laid out to match a
    ;;; printed pro-forma rather than coming out alphabetically.
    ;;;
    ;;;   lst - the current list of tag names
    ;;;
    ;;; Returns the new list.
    ;;; -----------------------------------------------------------------------

    (defun AH:ChooseTags ( lst / at old str tmp )
        (if (not (new_dialog "ah_tags" dch))
            (progn (princ "\nUnable to open the tag dialog.") lst)
            (progn
                (AH:FillList "tag_list" (setq tmp lst))
                (mode_tile "tag" 2)

                (action_tile "tag"      "(setq str $value)")
                (action_tile "tag_list" "(setq at $value)")

                (action_tile "abc"
                    (vl-prin1-to-string
                       '(if tmp (AH:FillList "tag_list" (setq tmp (acad_strlsort tmp))))
                    )
                )

                ;;  Up and Down: the highlighted names are remembered, the
                ;;  list is rearranged, and the highlight set from where those
                ;;  names now are -- so the buttons can be pressed repeatedly.
                (action_tile "up"
                    (vl-prin1-to-string
                       '(if at
                            (progn
                                (setq old (mapcar '(lambda ( n ) (nth n tmp))
                                                  (read (strcat "(" at ")"))))
                                (AH:FillList "tag_list"
                                    (setq tmp (AttHarvest:ListUp
                                                  (read (strcat "(" at ")")) tmp)))
                                (set_tile "tag_list"
                                    (setq at (AttHarvest:ToValue
                                                 (mapcar '(lambda ( x ) (vl-position x tmp)) old))))
                            )
                            (alert "Select one or more tags to move.")
                        )
                    )
                )
                (action_tile "down"
                    (vl-prin1-to-string
                       '(if at
                            (progn
                                (setq old (mapcar '(lambda ( n ) (nth n tmp))
                                                  (read (strcat "(" at ")"))))
                                (AH:FillList "tag_list"
                                    (setq tmp (AttHarvest:ListDown
                                                  (read (strcat "(" at ")")) tmp)))
                                (set_tile "tag_list"
                                    (setq at (AttHarvest:ToValue
                                                 (mapcar '(lambda ( x ) (vl-position x tmp)) old))))
                            )
                            (alert "Select one or more tags to move.")
                        )
                    )
                )

                (action_tile "tag_add"
                    (vl-prin1-to-string
                       '(cond
                            (   (or (null str) (= "" str))
                                (alert "Enter a tag name to add.")
                            )
                            ;;  snvalid checks the name against AutoCAD's
                            ;;  rules for symbol names; spaces pass that test
                            ;;  but are not valid in an attribute tag, so they
                            ;;  are rejected separately.
                            (   (or (not (snvalid str)) (vl-string-position 32 str))
                                (alert (strcat "That is not a valid attribute tag."
                                               (if (vl-string-position 32 str)
                                                   "\n\nTags cannot contain spaces." "")))
                            )
                            (   (vl-position (strcase str) tmp)
                                (alert "That tag is already in the list.")
                            )
                            (   t
                                (set_tile "tag" "")
                                (AH:FillList "tag_list"
                                    (setq tmp (append tmp (list (strcase str)))))
                                (setq str nil)
                            )
                        )
                    )
                )

                (action_tile "tag_rem"
                    (vl-prin1-to-string
                       '(cond
                            (   (null tmp) (alert "There are no tags to remove."))
                            (   (and at (listp (setq items (read (strcat "(" at ")")))))
                                (setq tmp (AttHarvest:RemoveNth items tmp)
                                      at  nil
                                )
                                (AH:FillList "tag_list" tmp)
                            )
                            (   (alert "Select a tag to remove."))
                        )
                    )
                )

                (action_tile "accept" "(setq lst tmp) (done_dialog)")
                (action_tile "cancel" "(done_dialog)")
                (start_dialog)
                (if (listp lst) lst (list lst))
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; AH:ChooseTagsB
    ;;;
    ;;; The same tag chooser with the block name editable too, used when an
    ;;; existing entry is double-clicked.
    ;;;
    ;;;   entry - (block-name tag tag ...)
    ;;;
    ;;; Returns the amended entry.
    ;;; -----------------------------------------------------------------------

    (defun AH:ChooseTagsB ( entry / at bstr old others str tmp )

        ;; Every OTHER block name in the list, so the duplicate check does
        ;; not reject the entry for matching itself.
        (setq others
            (vl-remove (strcase (car entry))
                (mapcar '(lambda ( x ) (strcase (car x))) AH:Blocks))
        )

        (if (not (new_dialog "ah_tagsb" dch))
            (progn (princ "\nUnable to open the tag dialog.") entry)
            (progn
                (AH:FillList "tag_list" (setq tmp (cdr entry)))
                (set_tile "blk" (setq bstr (car entry)))
                (mode_tile "tag" 2)

                (action_tile "blk"      "(setq bstr $value)")
                (action_tile "tag"      "(setq str $value)")
                (action_tile "tag_list" "(setq at $value)")

                (action_tile "abc"
                    (vl-prin1-to-string
                       '(if tmp (AH:FillList "tag_list" (setq tmp (acad_strlsort tmp))))
                    )
                )
                (action_tile "up"
                    (vl-prin1-to-string
                       '(if at
                            (progn
                                (setq old (mapcar '(lambda ( n ) (nth n tmp))
                                                  (read (strcat "(" at ")"))))
                                (AH:FillList "tag_list"
                                    (setq tmp (AttHarvest:ListUp
                                                  (read (strcat "(" at ")")) tmp)))
                                (set_tile "tag_list"
                                    (setq at (AttHarvest:ToValue
                                                 (mapcar '(lambda ( x ) (vl-position x tmp)) old))))
                            )
                        )
                    )
                )
                (action_tile "down"
                    (vl-prin1-to-string
                       '(if at
                            (progn
                                (setq old (mapcar '(lambda ( n ) (nth n tmp))
                                                  (read (strcat "(" at ")"))))
                                (AH:FillList "tag_list"
                                    (setq tmp (AttHarvest:ListDown
                                                  (read (strcat "(" at ")")) tmp)))
                                (set_tile "tag_list"
                                    (setq at (AttHarvest:ToValue
                                                 (mapcar '(lambda ( x ) (vl-position x tmp)) old))))
                            )
                        )
                    )
                )

                (action_tile "tag_add"
                    (vl-prin1-to-string
                       '(cond
                            (   (or (null str) (= "" str))
                                (alert "Enter a tag name to add.")
                            )
                            (   (or (not (snvalid str)) (vl-string-position 32 str))
                                (alert (strcat "That is not a valid attribute tag."
                                               (if (vl-string-position 32 str)
                                                   "\n\nTags cannot contain spaces." "")))
                            )
                            (   (vl-position (strcase str) tmp)
                                (alert "That tag is already in the list.")
                            )
                            (   t
                                (set_tile "tag" "")
                                (AH:FillList "tag_list"
                                    (setq tmp (append tmp (list (strcase str)))))
                                (setq str nil)
                            )
                        )
                    )
                )

                (action_tile "tag_rem"
                    (vl-prin1-to-string
                       '(cond
                            (   (null tmp) (alert "There are no tags to remove."))
                            (   (and at (listp (setq items (read (strcat "(" at ")")))))
                                (setq tmp (AttHarvest:RemoveNth items tmp)
                                      at  nil
                                )
                                (AH:FillList "tag_list" tmp)
                            )
                            (   (alert "Select a tag to remove."))
                        )
                    )
                )

                (action_tile "accept"
                    (vl-prin1-to-string
                       '(cond
                            (   (or (null bstr) (= "" bstr))
                                (alert "Enter a block name.")
                            )
                            (   (not (snvalid bstr))
                                (alert "That is not a valid block name.")
                            )
                            (   (vl-position (strcase bstr) others)
                                (alert "That block is already in the list.")
                            )
                            (   t (setq entry (cons bstr tmp)) (done_dialog))
                        )
                    )
                )
                (action_tile "cancel" "(done_dialog)")
                (start_dialog)
                entry
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; AH:EditTag
    ;;;
    ;;; Edits one tag and its replacement value, used when an entry in the
    ;;; editor's list is double-clicked.
    ;;;
    ;;;   entry - (tag . value)
    ;;;
    ;;; Returns the amended entry.
    ;;; -----------------------------------------------------------------------

    (defun AH:EditTag ( entry / others tag val )

        ;; Every OTHER tag in the list, for the duplicate check.
        (setq others
            (vl-remove-if
               '(lambda ( x ) (= (strcase (car entry)) (strcase (car x))))
                AH:Tags
            )
        )

        (if (not (new_dialog "ah_edit" dch))
            (progn (princ "\nUnable to open the edit dialog.") entry)
            (progn
                (set_tile "tag_sub"       (setq tag (car entry)))
                (set_tile "new_value_sub" (setq val (cond ((cdr entry)) (""))))
                (action_tile "tag_sub"       "(setq tag $value)")
                (action_tile "new_value_sub" "(setq val $value)")

                (action_tile "accept"
                    (vl-prin1-to-string
                       '(cond
                            (   (or (null tag) (= "" tag))
                                (alert "Enter a tag name.")
                            )
                            (   (or (not (snvalid tag)) (vl-string-position 32 tag))
                                (alert (strcat "That is not a valid attribute tag."
                                               (if (vl-string-position 32 tag)
                                                   "\n\nTags cannot contain spaces." "")))
                            )
                            (   (assoc (setq tag (strcase tag)) others)
                                (alert "That tag is already in the list.")
                            )
                            (   t
                                ;; An empty value is stored as nil, which the
                                ;; list display shows as "- NO VALUE -" and
                                ;; which writes an empty attribute.
                                (if (= "" val) (setq val nil))
                                (setq entry (cons tag val))
                                (done_dialog)
                            )
                        )
                    )
                )
                (action_tile "cancel" "(done_dialog)")
                (start_dialog)
                entry
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; AH:Options
    ;;;
    ;;; The extractor's layout options.
    ;;; -----------------------------------------------------------------------

    (defun AH:Options ( group / newgroup newcoords )
        (if (not (new_dialog "ah_options" dch))
            (progn (princ "\nUnable to open the options dialog.") group)
            (progn
                (set_tile (setq newgroup group) "1")
                (setq newcoords (set_tile "coord" AH:Coords))
                ;; Each radio button records its own key as the new setting,
                ;; which is also the tile name -- so one loop wires all three.
                (foreach key '("grp_file" "grp_block" "grp_dwglst")
                    (action_tile key (strcat "(setq newgroup " (vl-prin1-to-string key) ")"))
                )
                (action_tile "coord"  "(setq newcoords $value)")
                (action_tile "accept"
                    "(setq group newgroup AH:Coords newcoords) (done_dialog)")
                (action_tile "cancel" "(done_dialog)")
                (start_dialog)
                group
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; AH:NewInsPoint
    ;;;
    ;;; Returns the insertion point an attribute needs so it stays visually
    ;;; put after its value changes length.
    ;;;
    ;;; An attribute is anchored at its insertion point, but a centred or
    ;;; right-justified one grows away from that anchor in the wrong
    ;;; direction. The width difference between old and new text is measured
    ;;; with textbox, and the anchor moved by half of it for centre and
    ;;; middle justification, all of it for right, and none for left.
    ;;; -----------------------------------------------------------------------

    (defun AH:NewInsPoint ( obj str / enx just )
        (setq enx  (entget (vlax-vla-object->ename obj))
              just (cdr (assoc 72 enx))
        )
        (polar
            (vlax-get obj 'insertionpoint)
            (vla-get-rotation obj)
            (*
                (apply '+
                    (mapcar '(lambda ( a b ) (- (car a) (car b)))
                        (textbox enx)
                        (textbox (subst (cons 1 str) (assoc 1 enx) enx))
                    )
                )
                (cond
                    (   (or (= 1 just) (= 4 just)) 0.5)   ;; centre, middle
                    (   (= 2 just) 1.0)                   ;; right
                    (   0.0)                              ;; left
                )
            )
        )
    )

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

    (setvar 'cmdecho 0)
    ;; DIMZIN 0 keeps trailing zeros on the coordinates written to Excel, so
    ;; a column of numbers lines up instead of being ragged.
    (setvar 'dimzin 0)

    (setq acapp (vlax-get-acad-object)
          acdoc (vla-get-activedocument acapp)
          cfg   (strcat (AttHarvest:SavePath) "\\YZ_AttHarvest.cfg")
    )

    ;; ---- load the settings --------------------------------------------------
    ;; The two modes keep separate settings, so switching between them does
    ;; not disturb the other's block list or folder.

    (setq names  '(AH:Sub AH:Blocks AH:Path AH:Cur AH:Group AH:Coords
                   AH:ESub AH:Tags AH:EPath AH:ECur AH:EBlock)
          values  (list "1" nil (getvar 'dwgprefix) "0" "grp_file" "0"
                        "1" nil (getvar 'dwgprefix) "0" nil)
    )
    (if (not (findfile cfg)) (AttHarvest:WriteConfig cfg values))
    (AttHarvest:ReadConfig cfg names)
    (mapcar '(lambda ( sym val ) (or (boundp sym) (set sym val))) names values)

    ;; ---- build the dialog ---------------------------------------------------
    ;; Written to a uniquely named temporary file, loaded, and deleted on
    ;; exit, so two AutoCAD sessions cannot collide and nothing is left behind.

    (cond
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line
                           '(
                                "boxcol  : boxed_column { width = 60; fixed_width = true; alignment = centered; }"
                                "subcol  : boxed_column { width = 40; fixed_width = true; alignment = centered; }"
                                "edit34  : edit_box { edit_width = 34; fixed_width = true; alignment = centered; }"
                                "edit34r : edit_box { edit_width = 34; fixed_width = true; alignment = right; }"
                                "butt3   : button { width =  3; fixed_width = true; alignment = centered; }"
                                "butt10  : button { width = 10; fixed_width = true; alignment = centered; }"
                                "butt12  : button { width = 12; fixed_width = true; alignment = centered; }"
                                "butt20  : button { width = 20; fixed_width = true; alignment = centered; }"
                                "space1  : spacer { height = 0.1; fixed_height = true; }"
                                ""
                                "ah_pull : dialog { label = \"Attribute Harvest - Extract\";"
                                "  spacer;"
                                "  : boxcol { label = \"Block Entry\";"
                                "    : row {"
                                "      : edit34 { key = \"block_name\"; label = \"Block Name:\"; }"
                                "      : butt3  { key = \"block_pick\"; label = \">>\"; }"
                                "    }"
                                "    : row {"
                                "      spacer;"
                                "      : column {"
                                "        space1;"
                                "        : toggle { label = \"All Tags\"; key = \"tags\";"
                                "                   fixed_width = true; alignment = centered; }"
                                "        space1;"
                                "      }"
                                "      : butt20 { label = \"Choose Tags...\"; key = \"tag_button\"; }"
                                "      spacer;"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : row {"
                                "    spacer;"
                                "    : butt20 { key = \"add\"; label = \"Add Block\"; }"
                                "    : butt10 { key = \"clr\"; label = \"Clear\"; }"
                                "    : butt20 { key = \"rem\"; label = \"Remove Block\"; }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : list_box { key = \"block_list\"; multiple_select = true; fixed_width = false;"
                                "               alignment = centered; tabs = \"30\"; tab_truncate = true; }"
                                "  : text { label = \"Double-click an entry to edit it   \"; alignment = right; }"
                                "  : boxcol { label = \"Drawing Folder\";"
                                "    : row {"
                                "      : column { space1;"
                                "        : text { key = \"dir_text\"; alignment = left; }"
                                "        space1; }"
                                "      : butt10 { label = \"Folder...\"; key = \"dir\"; }"
                                "    }"
                                "    : row {"
                                "      : toggle { key = \"sub_dir\"; label = \"Include sub-folders\"; }"
                                "      : toggle { key = \"cur_dwg\"; label = \"Current drawing only\"; }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : row {"
                                "    : butt12 { key = \"option\"; label = \"Options\"; }"
                                "    : butt12 { key = \"accept\"; label = \"OK\"; is_default = true; }"
                                "    : butt12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
                                "  }"
                                "}"
                                ""
                                "ah_options : dialog { label = \"Extract Options\";"
                                "  spacer;"
                                "  : boxed_radio_column { label = \"Layout\";"
                                "    spacer;"
                                "    : radio_button { key = \"grp_file\";   label = \" Group by filename\"; }"
                                "    : radio_button { key = \"grp_block\";  label = \" Group by block\"; }"
                                "    : radio_button { key = \"grp_dwglst\"; label = \" Flat table (drawing list)\"; }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : row { spacer;"
                                "    : toggle { key = \"coord\"; label = \" Include block coordinates\"; }"
                                "  }"
                                "  spacer; ok_cancel;"
                                "}"
                                ""
                                "ah_tags : dialog { label = \"Attributes to Extract\";"
                                "  spacer_1;"
                                "  : edit34 { label = \"Tag:\"; key = \"tag\"; }"
                                "  spacer_1;"
                                "  : row {"
                                "    : butt20 { label = \"Add Tag\";    key = \"tag_add\"; }"
                                "    : butt20 { label = \"Remove Tag\"; key = \"tag_rem\"; }"
                                "  }"
                                "  spacer;"
                                "  : list_box { label = \"Tags to extract, in column order:\";"
                                "               multiple_select = true; key = \"tag_list\";"
                                "               fixed_width = false; alignment = centered; }"
                                "  : boxed_column { label = \"Tag Order\";"
                                "    : row {"
                                "      spacer;"
                                "      : butt10 { label = \"Up\";   key = \"up\"; }"
                                "      : butt10 { label = \"Down\"; key = \"down\"; }"
                                "      : butt10 { label = \"ABC\";  key = \"abc\"; }"
                                "      spacer;"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer_1; ok_cancel;"
                                "}"
                                ""
                                "ah_tagsb : dialog { label = \"Edit Block Entry\";"
                                "  spacer_1;"
                                "  : edit34r { label = \"Block:\"; key = \"blk\"; }"
                                "  spacer_1;"
                                "  : edit34r { label = \"Tag:\";   key = \"tag\"; }"
                                "  spacer_1;"
                                "  : row {"
                                "    : butt20 { label = \"Add Tag\";    key = \"tag_add\"; }"
                                "    : butt20 { label = \"Remove Tag\"; key = \"tag_rem\"; }"
                                "  }"
                                "  spacer;"
                                "  : list_box { label = \"Tags to extract, in column order:\"; key = \"tag_list\";"
                                "               fixed_width = false; multiple_select = true; alignment = centered; }"
                                "  : boxed_column { label = \"Tag Order\";"
                                "    : row {"
                                "      spacer;"
                                "      : butt10 { label = \"Up\";   key = \"up\"; }"
                                "      : butt10 { label = \"Down\"; key = \"down\"; }"
                                "      : butt10 { label = \"ABC\";  key = \"abc\"; }"
                                "      spacer;"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer_1; ok_cancel;"
                                "}"
                                ""
                                "ah_push : dialog { label = \"Attribute Harvest - Write Values\";"
                                "  spacer;"
                                "  : boxcol { label = \"Block Entry\";"
                                "    : row {"
                                "      : edit34 { key = \"block_name\"; label = \"Block Name:\"; }"
                                "      : butt3  { key = \"block_pick\"; label = \">>\"; }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  : boxcol { label = \"Tag Entry\";"
                                "    : row {"
                                "      : edit34 { key = \"tag_name\"; label = \"Tag Name:\"; }"
                                "      : butt3  { key = \"tag_pick\"; label = \">>\"; }"
                                "    }"
                                "    : row {"
                                "      : edit34 { key = \"new_value\"; label = \"New Value:\"; }"
                                "      : spacer { width = 3; fixed_width = true; }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : row {"
                                "    spacer;"
                                "    : butt20 { key = \"add\"; label = \"Add Tag\"; }"
                                "    : butt10 { key = \"clr\"; label = \"Clear\"; }"
                                "    : butt20 { key = \"rem\"; label = \"Remove Tag\"; }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : list_box { key = \"tag_list\"; multiple_select = true;"
                                "               fixed_width = false; alignment = centered; tabs = \"30\"; }"
                                "  : text { label = \"Double-click an entry to edit it   \"; alignment = right; }"
                                "  : boxcol { label = \"Drawing Folder\";"
                                "    : row {"
                                "      : column { space1;"
                                "        : text { key = \"dir_text\"; alignment = left; }"
                                "        space1; }"
                                "      : butt10 { label = \"Folder...\"; key = \"dir\"; }"
                                "    }"
                                "    : row {"
                                "      : toggle { key = \"sub_dir\"; label = \"Include sub-folders\"; }"
                                "      : toggle { key = \"cur_dwg\"; label = \"Current drawing only\"; }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer; ok_cancel;"
                                "}"
                                ""
                                "ah_edit : dialog { label = \"New Attribute Value\";"
                                "  : subcol { label = \"Tag Entry\";"
                                "    : edit34r { label = \"Tag Name:\";  key = \"tag_sub\"; }"
                                "    : edit34r { label = \"New Value:\"; key = \"new_value_sub\"; }"
                                "    spacer;"
                                "  }"
                                "  spacer; ok_cancel;"
                                "}"
                            )
                            (write-line line des)
                        )
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                )
            )
            (princ "\nUnable to create the dialog.")
        )

        ;;  ====================================================================
        ;;                      E X T R A C T   M O D E
        ;;  ====================================================================

        (   pull
            ;; The dialog reopens after the "pick block" button, which has to
            ;; close it to let the user reach the drawing.
            (while (not (member flag '(0 1)))
                (if (not (new_dialog "ah_pull" dch))
                    (progn (princ "\nUnable to display the dialog.") (setq flag 0))
                    (progn
                        (AH:ShowBlocks "block_list"
                            (setq AH:Blocks (AttHarvest:SortByFirst AH:Blocks)))
                        (AH:ShowPath "dir_text" AH:Path)
                        (set_tile "sub_dir" AH:Sub)
                        ;; A new entry starts as "all tags", with the tag
                        ;; chooser greyed out until that is unticked.
                        (set_tile  "tags" "1")
                        (mode_tile "tag_button" 1)
                        (AH:FolderMode (set_tile "cur_dwg" AH:Cur))

                        ;;; -----------------------------------------------
                        ;;; Callbacks.
                        ;;;
                        ;;; Written as quoted lists and converted with
                        ;;; vl-prin1-to-string, which produces correct
                        ;;; quoting every time where hand-escaping does not.
                        ;;; -----------------------------------------------

                        (action_tile "cur_dwg" "(AH:FolderMode (setq AH:Cur $value))")
                        (action_tile "sub_dir" "(setq AH:Sub $value)")
                        (action_tile "option"  "(setq AH:Group (AH:Options AH:Group))")
                        (action_tile "tags"    "(mode_tile \"tag_button\" (atoi $value))")
                        (action_tile "tag_button" "(setq taglst (AH:ChooseTags taglst))")
                        (action_tile "block_name" "(setq blkstr $value)")

                        (action_tile "dir"
                            (vl-prin1-to-string
                               '(if (setq tmp (AttHarvest:PickFolder
                                                  "Select the folder of drawings to process..."
                                                  nil 0))
                                    (AH:ShowPath "dir_text" (setq AH:Path tmp))
                                )
                            )
                        )

                        (action_tile "add"
                            (vl-prin1-to-string
                               '(cond
                                    (   (or (null blkstr) (= "" blkstr))
                                        (alert "Enter a block name.")
                                    )
                                    (   (not (snvalid blkstr))
                                        (alert "That is not a valid block name.")
                                    )
                                    (   (vl-position (strcase blkstr)
                                            (mapcar '(lambda ( x ) (strcase (car x))) AH:Blocks))
                                        (alert "That block is already in the list.")
                                    )
                                    (   t
                                        (set_tile "block_name" "")
                                        ;; The "All Tags" tick overrides
                                        ;; anything chosen in the tag dialog.
                                        (if (= "1" (get_tile "tags")) (setq taglst nil))
                                        (AH:ShowBlocks "block_list"
                                            (setq AH:Blocks
                                                (AttHarvest:SortByFirst
                                                    (cons (cons blkstr taglst) AH:Blocks))))
                                        (set_tile  "tags" "1")
                                        (mode_tile "tag_button" 1)
                                        (setq blkstr nil taglst nil)
                                    )
                                )
                            )
                        )

                        (action_tile "rem"
                            (vl-prin1-to-string
                               '(cond
                                    (   (null AH:Blocks)
                                        (alert "There are no blocks to remove.")
                                    )
                                    (   (and ptr (listp (setq items (read (strcat "(" ptr ")")))))
                                        (setq AH:Blocks (AttHarvest:RemoveNth items AH:Blocks)
                                              ptr       nil
                                        )
                                        (AH:ShowBlocks "block_list"
                                            (setq AH:Blocks (AttHarvest:SortByFirst AH:Blocks)))
                                    )
                                    (   (alert "Select a block from the list to remove."))
                                )
                            )
                        )

                        (action_tile "clr"
                            "(AH:ShowBlocks \"block_list\" (setq AH:Blocks nil))")

                        ;;  $reason 4 is a double-click, which edits the entry.
                        (action_tile "block_list"
                            (vl-prin1-to-string
                               '(progn
                                    (setq ptr $value)
                                    (if (and (= 4 $reason)
                                             (setq idx (car (read (strcat "(" ptr ")"))))
                                             (setq item (nth idx AH:Blocks))
                                        )
                                        (AH:ShowBlocks "block_list"
                                            (setq AH:Blocks
                                                (AttHarvest:SortByFirst
                                                    (subst (AH:ChooseTagsB item) item AH:Blocks))))
                                    )
                                )
                            )
                        )

                        (action_tile "block_pick" "(done_dialog 2)")
                        (action_tile "accept"
                            (vl-prin1-to-string
                               '(if (null AH:Blocks)
                                    (alert "Add at least one block to the list.")
                                    (done_dialog 1)
                                )
                            )
                        )
                        (action_tile "cancel" "(done_dialog 0)")
                        (setq flag (start_dialog))
                    )
                )

                ;;  ---- pick blocks from the drawing ----
                ;;  Every attributed block picked is added with its full tag
                ;;  list, which is far quicker than typing them.
                (if (= 2 flag)
                    (if (setq sel (ssget '((0 . "INSERT") (66 . 1))))
                        (progn
                            (setq idx -1)
                            (while (setq item (ssname sel (setq idx (1+ idx))))
                                (setq item    (vlax-ename->vla-object item)
                                      blkname (AttHarvest:BlockName item)
                                )
                                (if (not (vl-position (strcase blkname)
                                             (mapcar '(lambda ( x ) (strcase (car x))) AH:Blocks)))
                                    (setq AH:Blocks
                                        (cons (cons blkname
                                                    (mapcar 'vla-get-tagstring
                                                            (AttHarvest:AllAttributes item)))
                                              AH:Blocks)
                                    )
                                )
                            )
                        )
                    )
                )
            )

            (setq dch (unload_dialog dch))
            (vl-file-delete dcl)
            (setq dcl nil)

            (if (/= 1 flag)
                (princ "\nCancelled.")
                (progn
                    ;; ---- gather the data --------------------------------
                    ;; Names are upper-cased once here so every later lookup
                    ;; is a plain assoc rather than a case-insensitive search.
                    (setq blocks
                        (mapcar '(lambda ( x ) (cons (strcase (car x)) (cdr x))) AH:Blocks)
                    )
                    (vlax-for doc (vla-get-documents acapp)
                        (setq opened (cons (cons (strcase (vla-get-fullname doc)) doc) opened))
                    )
                    (setq dbx  (AttHarvest:DbxDocument acapp)
                          dwgs (if (= "1" AH:Cur)
                                   (list (AttHarvest:DocPath acdoc))
                                   (AttHarvest:AllFiles AH:Path (= "1" AH:Sub) "*.dwg")
                               )
                    )

                    (if (vl-position "acetutil.arx" (arx))
                        (setq progress
                            (not (vl-catch-all-error-p
                                     (vl-catch-all-apply 'acet-ui-progress
                                         (list "Extracting..." (length dwgs)))))
                        )
                    )

                    (foreach dwg dwgs
                        (if progress (vl-catch-all-apply 'acet-ui-progress '(-1)))
                        (setq doc
                            (cond
                                (   (= "1" AH:Cur) acdoc)
                                ;;  Already open: read the live document, or
                                ;;  unsaved work would be silently missed.
                                (   (cdr (assoc (strcase dwg) opened)))
                                (   (and dbx
                                         (not (vl-catch-all-error-p
                                                  (vl-catch-all-apply 'vla-open (list dbx dwg)))))
                                    dbx
                                )
                            )
                        )
                        (if (null doc)
                            (princ (strcat "\n** Unable to open: " (vl-filename-base dwg) ".dwg"))
                            (progn
                                (setq found nil)
                                (vlax-for lay (vla-get-layouts doc)
                                    (vlax-for obj (vla-get-block lay)
                                        (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
                                                 (= :vlax-true (vla-get-hasattributes obj))
                                                 (setq item (assoc (strcase
                                                                       (setq blkname
                                                                           (AttHarvest:BlockName obj)))
                                                                   blocks))
                                            )
                                            (progn
                                                ;; An empty tag list means
                                                ;; "every tag this block has".
                                                (setq allatts (mapcar 'strcase (cdr item))
                                                      lst     nil
                                                )
                                                (foreach att (AttHarvest:AllAttributes obj)
                                                    (if (or (null allatts)
                                                            (vl-position
                                                                (strcase (vla-get-tagstring att))
                                                                allatts))
                                                        (setq lst
                                                            (cons (cons (vla-get-tagstring att)
                                                                        (list (vla-get-textstring att)))
                                                                  lst)
                                                        )
                                                    )
                                                )
                                                ;; Two synthetic columns,
                                                ;; treated exactly like real
                                                ;; tags so the layout code
                                                ;; needs no special case.
                                                (if (= "grp_dwglst" AH:Group)
                                                    (setq lst (cons (cons "CAD Filename" (list dwg)) lst))
                                                )
                                                (if (= "1" AH:Coords)
                                                    (setq lst
                                                        (cons (cons "Block Coords"
                                                                    (list (AttHarvest:Join
                                                                              (mapcar 'rtos
                                                                                  (vlax-get obj 'insertionpoint))
                                                                              ",")))
                                                              lst)
                                                    )
                                                )
                                                (setq found (cons (cons blkname lst) found))
                                            )
                                        )
                                    )
                                )
                                (if found
                                    ;; Merge the entries for each block name,
                                    ;; then for each tag within them, so one
                                    ;; block appearing twenty times becomes
                                    ;; one entry with twenty values per tag.
                                    (setq rows
                                        (cons (cons dwg
                                                    (AttHarvest:SortByFirst
                                                        (mapcar '(lambda ( x )
                                                                     (cons (car x)
                                                                           (AttHarvest:MergeAssoc (cdr x))))
                                                                (AttHarvest:MergeAssoc found))))
                                              rows)
                                    )
                                    (princ (strcat "\n-- No matching blocks in "
                                                   (vl-filename-base dwg) ".dwg"))
                                )
                            )
                        )
                    )
                    (if progress
                        (progn (vl-catch-all-apply 'acet-ui-progress) (setq progress nil))
                    )

                    ;; ---- write it to Excel -------------------------------
                    (if (null (and rows (apply 'or (apply 'append (mapcar 'cadr rows)))))
                        (princ "\nNo attribute data was found.")
                        (progn
                            (setq xlapp (vl-catch-all-apply 'vlax-get-or-create-object
                                            '("Excel.Application")))
                            (if (vl-catch-all-error-p xlapp)
                                (progn
                                    (setq xlapp nil)
                                    (alert (strcat "Microsoft Excel could not be started.\n\n"
                                                   "Excel must be installed to extract "
                                                   "attribute data."))
                                )
                                (progn
                                    ;; A fresh workbook, and a handle on the
                                    ;; first sheet's cells -- everything is
                                    ;; written through that one object.
                                    (setq xlcells
                                        (vlax-get-property
                                            (vlax-get-property
                                                (vlax-get-property
                                                    (vlax-invoke-method
                                                        (vlax-get-property xlapp "Workbooks") "Add")
                                                    "Sheets")
                                                "Item" 1)
                                            "Cells")
                                    )
                                    (cond
                                        (   (= "grp_file"  AH:Group)
                                            (AttHarvest:WriteByFile  xlcells rows blocks AH:Coords))
                                        (   (= "grp_block" AH:Group)
                                            (AttHarvest:WriteByBlock xlcells rows blocks AH:Coords))
                                        (   t
                                            (AttHarvest:WriteFlat    xlcells rows blocks))
                                    )
                                    ;; Excel is left running and visible: the
                                    ;; workbook is the result of the command.
                                    (vla-put-visible xlapp :vlax-true)
                                    (princ (strcat "\n" (itoa (length dwgs)) " drawing"
                                                   (if (= 1 (length dwgs)) "" "s")
                                                   " processed."))
                                )
                            )
                        )
                    )
                    (AttHarvest:WriteConfig cfg (mapcar 'eval names))
                )
            )
        )

        ;;  ====================================================================
        ;;                        W R I T E   M O D E
        ;;  ====================================================================

        (   t
            (while (not (member flag '(0 1)))
                (if (not (new_dialog "ah_push" dch))
                    (progn (princ "\nUnable to display the dialog.") (setq flag 0))
                    (progn
                        (AH:ShowTags "tag_list" (setq AH:Tags (AttHarvest:SortByFirst AH:Tags)))
                        (AH:ShowPath "dir_text" AH:EPath)
                        (set_tile "sub_dir"    AH:ESub)
                        (set_tile "block_name" (cond (AH:EBlock) ("")))
                        (set_tile "tag_name"   (cond (tagstr)    ("")))
                        (set_tile "new_value"  (cond (newval)    ("")))
                        (AH:FolderMode (set_tile "cur_dwg" AH:ECur))

                        (action_tile "cur_dwg"    "(AH:FolderMode (setq AH:ECur $value))")
                        (action_tile "sub_dir"    "(setq AH:ESub $value)")
                        (action_tile "block_name" "(setq AH:EBlock $value)")
                        (action_tile "tag_name"   "(setq tagstr $value)")
                        (action_tile "new_value"  "(setq newval $value)")

                        (action_tile "dir"
                            (vl-prin1-to-string
                               '(if (setq tmp (AttHarvest:PickFolder
                                                  "Select the folder of drawings to process..."
                                                  nil 0))
                                    (AH:ShowPath "dir_text" (setq AH:EPath tmp))
                                )
                            )
                        )

                        (action_tile "add"
                            (vl-prin1-to-string
                               '(cond
                                    (   (or (null AH:EBlock) (= "" AH:EBlock))
                                        (alert "Enter a block name.")
                                    )
                                    (   (not (snvalid AH:EBlock))
                                        (alert "That is not a valid block name.")
                                    )
                                    (   (or (null tagstr) (= "" tagstr))
                                        (alert "Enter a tag name.")
                                    )
                                    (   (or (not (snvalid tagstr)) (vl-string-position 32 tagstr))
                                        (alert (strcat "That is not a valid attribute tag."
                                                       (if (vl-string-position 32 tagstr)
                                                           "\n\nTags cannot contain spaces." "")))
                                    )
                                    (   (vl-position (strcase tagstr)
                                            (mapcar '(lambda ( x ) (strcase (car x))) AH:Tags))
                                        (alert "That tag is already in the list.")
                                    )
                                    (   t
                                        (mapcar 'set_tile '("tag_name" "new_value") '("" ""))
                                        ;; An empty value is stored as nil,
                                        ;; which writes an empty attribute.
                                        (if (= "" newval) (setq newval nil))
                                        (AH:ShowTags "tag_list"
                                            (setq AH:Tags
                                                (AttHarvest:SortByFirst
                                                    (cons (cons (strcase tagstr) newval) AH:Tags))))
                                        (setq tagstr nil newval nil)
                                    )
                                )
                            )
                        )

                        (action_tile "rem"
                            (vl-prin1-to-string
                               '(cond
                                    (   (null AH:Tags) (alert "There are no tags to remove."))
                                    (   (and ptr (listp (setq items (read (strcat "(" ptr ")")))))
                                        (setq AH:Tags (AttHarvest:RemoveNth items AH:Tags)
                                              ptr     nil
                                        )
                                        (AH:ShowTags "tag_list"
                                            (setq AH:Tags (AttHarvest:SortByFirst AH:Tags)))
                                    )
                                    (   (alert "Select a tag from the list to remove."))
                                )
                            )
                        )

                        (action_tile "clr" "(AH:ShowTags \"tag_list\" (setq AH:Tags nil))")

                        (action_tile "tag_list"
                            (vl-prin1-to-string
                               '(progn
                                    (setq ptr $value)
                                    (if (and (= 4 $reason)
                                             (setq idx (car (read (strcat "(" ptr ")"))))
                                             (setq item (nth idx AH:Tags))
                                        )
                                        (AH:ShowTags "tag_list"
                                            (setq AH:Tags
                                                (AttHarvest:SortByFirst
                                                    (subst (AH:EditTag item) item AH:Tags))))
                                    )
                                )
                            )
                        )

                        (action_tile "block_pick" "(done_dialog 2)")

                        ;;  Picking a tag needs the block to exist in THIS
                        ;;  drawing, since that is where it will be picked
                        ;;  from -- so that is checked before closing.
                        (action_tile "tag_pick"
                            (vl-prin1-to-string
                               '(cond
                                    (   (or (null AH:EBlock) (= "" AH:EBlock))
                                        (alert "Enter a block name first.")
                                    )
                                    (   (not (snvalid AH:EBlock))
                                        (alert "That is not a valid block name.")
                                    )
                                    (   (not (tblsearch "BLOCK" AH:EBlock))
                                        (alert (strcat "That block is not in this drawing.\n\n"
                                                       "It must be present here for its tags "
                                                       "to be selectable."))
                                    )
                                    (   (done_dialog 3))
                                )
                            )
                        )

                        (action_tile "accept"
                            (vl-prin1-to-string
                               '(cond
                                    (   (or (null AH:EBlock) (= "" AH:EBlock))
                                        (alert "Enter a block name.")
                                    )
                                    (   (not (snvalid AH:EBlock))
                                        (alert "That is not a valid block name.")
                                    )
                                    (   (null AH:Tags)
                                        (alert "Add at least one tag to the list.")
                                    )
                                    (   (done_dialog 1))
                                )
                            )
                        )
                        (action_tile "cancel" "(done_dialog 0)")
                        (setq flag (start_dialog))
                    )
                )

                (cond
                    ;;  ---- pick the block, and take its current tag values ----
                    (   (= 2 flag)
                        (while
                            (progn
                                (setq item (car (entsel "\nSelect block: ")))
                                (cond
                                    (   (= 'ename (type item))
                                        (if (and (= "INSERT" (cdr (assoc 0 (entget item))))
                                                 (= 1 (cdr (assoc 66 (entget item)))))
                                            (progn
                                                (setq item      (vlax-ename->vla-object item)
                                                      AH:EBlock (AttHarvest:BlockName item)
                                                      ;; Pre-load every tag
                                                      ;; with its current
                                                      ;; value, which is
                                                      ;; usually most of the
                                                      ;; list already built.
                                                      AH:Tags
                                                          (mapcar '(lambda ( a )
                                                                       (cons (vla-get-tagstring a)
                                                                             (vla-get-textstring a)))
                                                                  (vlax-invoke item 'getattributes))
                                                )
                                                nil
                                            )
                                            (progn
                                                (princ "\nThat must be an attributed block.")
                                                t
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )

                    ;;  ---- pick one tag from that block ----
                    (   (= 3 flag)
                        (while
                            (progn
                                (setq item (car (nentsel "\nSelect attribute: ")))
                                (cond
                                    (   (= 'ename (type item))
                                        (if (/= "ATTRIB" (cdr (assoc 0 (entget item))))
                                            (progn (princ "\nThat must be an attribute.") t)
                                            ;; The attribute's owner is the
                                            ;; block reference containing it,
                                            ;; which must be the one named in
                                            ;; the dialog.
                                            (if (= (strcase AH:EBlock)
                                                   (strcase (AttHarvest:BlockName
                                                                (vla-objectidtoobject acdoc
                                                                    (vla-get-ownerid
                                                                        (vlax-ename->vla-object item))))))
                                                (progn
                                                    (setq tagstr (cdr (assoc 2 (entget item)))
                                                          newval (cdr (assoc 1 (entget item)))
                                                    )
                                                    nil
                                                )
                                                (progn
                                                    (princ (strcat "\nThat tag must belong to block: "
                                                                   AH:EBlock))
                                                    t
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )
                )
            )

            (setq dch (unload_dialog dch))
            (vl-file-delete dcl)
            (setq dcl nil)

            (if (/= 1 flag)
                (princ "\nCancelled.")
                (progn
                    (vla-startundomark acdoc)
                    (setq lst (mapcar '(lambda ( x ) (cons (strcase (car x)) (cdr x))) AH:Tags))
                    (vlax-for doc (vla-get-documents acapp)
                        (setq opened (cons (cons (strcase (vla-get-fullname doc)) doc) opened))
                    )
                    (setq dbx  (AttHarvest:DbxDocument acapp)
                          dwgs (if (= "1" AH:ECur)
                                   (list (AttHarvest:DocPath acdoc))
                                   (AttHarvest:AllFiles AH:EPath (= "1" AH:ESub) "*.dwg")
                               )
                          idx  0
                    )

                    (if (vl-position "acetutil.arx" (arx))
                        (setq progress
                            (not (vl-catch-all-error-p
                                     (vl-catch-all-apply 'acet-ui-progress
                                         (list "Updating attributes..." (length dwgs)))))
                        )
                    )

                    (foreach dwg dwgs
                        (if progress (vl-catch-all-apply 'acet-ui-progress '(-1)))
                        (setq changed nil
                              doc
                              (cond
                                  (   (= "1" AH:ECur) acdoc)
                                  (   (cdr (assoc (strcase dwg) opened)))
                                  (   (and dbx
                                           (not (vl-catch-all-error-p
                                                    (vl-catch-all-apply 'vla-open (list dbx dwg)))))
                                      dbx
                                  )
                              )
                        )
                        (if (null doc)
                            (princ (strcat "\n** Unable to open: " (vl-filename-base dwg) ".dwg"))
                            (progn
                                (vlax-for lay (vla-get-layouts doc)
                                    (vlax-for obj (vla-get-block lay)
                                        (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
                                                 (= :vlax-true (vla-get-hasattributes obj))
                                                 (= (strcase AH:EBlock)
                                                    (strcase (AttHarvest:BlockName obj)))
                                            )
                                            (foreach att (vlax-invoke obj 'getattributes)
                                                (if (setq item (assoc (strcase (vla-get-tagstring att))
                                                                      lst))
                                                    (progn
                                                        (setq tmp (cond ((cdr item)) ("")))
                                                        ;; Re-anchor first, so
                                                        ;; the shift is
                                                        ;; measured against
                                                        ;; the old text.
                                                        (vla-put-insertionpoint att
                                                            (vlax-3d-point (AH:NewInsPoint att tmp)))
                                                        (vla-put-textstring att tmp)
                                                        (setq changed t
                                                              idx     (1+ idx)
                                                        )
                                                    )
                                                )
                                            )
                                        )
                                    )
                                )
                                ;; Saved only if something actually changed,
                                ;; and never for an unsaved drawing -- which
                                ;; leaves the user's own work for them to save.
                                (if (and changed
                                         (not (and (vlax-property-available-p doc 'fullname)
                                                   (= "" (vla-get-fullname doc))))
                                    )
                                    (vla-saveas doc dwg)
                                )
                            )
                        )
                    )
                    (if progress
                        (progn (vl-catch-all-apply 'acet-ui-progress) (setq progress nil))
                    )

                    ;; The current drawing needs a regen to show the new
                    ;; values; the others are redrawn when they are opened.
                    (if (= "1" AH:ECur) (vla-regen acdoc acallviewports))

                    (princ (strcat "\n" (itoa idx) " attribute" (if (= 1 idx) "" "s")
                                   " updated across " (itoa (length dwgs)) " drawing"
                                   (if (= 1 (length dwgs)) "" "s") "."))
                    (AttHarvest:WriteConfig cfg (mapcar 'eval names))
                    (vla-endundomark acdoc)
                )
            )
        )
    )

    (AH:Restore)
    (princ)
)

;;; ===========================================================================
;;;                      E X C E L   L A Y O U T S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; AttHarvest:WriteByFile
;;;
;;; One section per drawing: the file name, then each block found in it, then
;;; that block's tags across the columns with their values running down.
;;;
;;; Each tag starts a new column but returns to the same row, so the values
;;; for one block line up as a table. The tallest column found sets where the
;;; next block begins, which is what keeps blocks from overlapping when they
;;; have different numbers of insertions.
;;;
;;; When specific tags were requested, they are written in the order the user
;;; put them in rather than the order they happen to appear in the block --
;;; which is what lets a schedule match a printed pro-forma.
;;;
;;;   cells  - the Excel Cells object
;;;   rows   - the gathered data
;;;   blocks - the block/tag request list, upper-cased
;;;   coords - "1" if the coordinate column was requested
;;; ---------------------------------------------------------------------------

(defun AttHarvest:WriteByFile ( cells rows blocks coords / col entry maxrow row start )
    (setq col 1 row 1 maxrow 1)
    (foreach dwg (reverse rows)
        (vlax-put-property cells 'item row col (car dwg))
        (setq row (1+ row))
        (foreach blk (cdr dwg)
            (vlax-put-property cells 'item row col (car blk))
            (setq row   (1+ row)
                  entry (assoc (strcase (car blk)) blocks)
            )
            (foreach tag (AttHarvest:OrderTags blk entry coords)
                (setq start row)
                (vlax-put-property cells 'item row col (car tag))
                (setq row (1+ row))
                (foreach val (cdr tag)
                    (vlax-put-property cells 'item row col val)
                    (setq row (1+ row))
                    (if (< maxrow row) (setq maxrow row))
                )
                ;; Next tag: new column, back to the same starting row.
                (setq col (1+ col)
                      row start
                )
            )
            (setq col 1
                  row (1+ maxrow)
            )
        )
        (setq row (1+ row))
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:WriteByBlock
;;;
;;; The same data merged across every drawing and grouped by block name, so
;;; one symbol's values from the whole project appear together.
;;;
;;; The merge is a two-stage fold: every drawing's block list is concatenated,
;;; entries with the same block name are combined, and then the tag entries
;;; within each are combined in turn.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:WriteByBlock ( cells rows blocks coords / col entry maxrow merged row start )

    (setq merged
        (AttHarvest:SortByFirst
            (mapcar '(lambda ( x ) (cons (car x) (reverse (AttHarvest:MergeAssoc (cdr x)))))
                (AttHarvest:MergeAssoc (apply 'append (mapcar 'cdr rows)))
            )
        )
    )

    (setq col 1 row 1 maxrow 1)
    (foreach blk merged
        (vlax-put-property cells 'item row col (car blk))
        (setq row   (1+ row)
              entry (assoc (strcase (car blk)) blocks)
        )
        (foreach tag (AttHarvest:OrderTags blk entry coords)
            (setq start row)
            (vlax-put-property cells 'item row col (car tag))
            (setq row (1+ row))
            (foreach val (cdr tag)
                (vlax-put-property cells 'item row col val)
                (setq row (1+ row))
                (if (< maxrow row) (setq maxrow row))
            )
            (setq col (1+ col)
                  row start
            )
        )
        (setq col 1
              row (1+ maxrow)
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:WriteFlat
;;;
;;; A single table: one column per tag, one row per block found, with the
;;; source drawing in its own column.
;;;
;;; This is the layout to use when the result is going to be sorted, filtered
;;; or pivoted, because it is a proper database table rather than a report.
;;;
;;; The column order is: the requested tags first, in the order the user put
;;; them in; then any other tag that turned up but was not asked for; then
;;; the two synthetic columns, CAD Filename and Block Coords, at the end
;;; where they do not interrupt the data.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:WriteFlat ( cells rows blocks / col extra merged order requested )

    ;; Every block from every drawing, flattened and merged by tag.
    (setq merged
        (reverse
            (AttHarvest:MergeAssoc
                (apply 'append
                    (mapcar 'cdr (apply 'append (mapcar 'cdr rows)))
                )
            )
        )
    )

    ;; The tags the user actually asked for, across all blocks.
    (setq requested (AttHarvest:Unique (apply 'append (mapcar 'cdr blocks))))

    ;; Anything else that appeared, excluding the two synthetic columns.
    (foreach pair merged
        (if (not (or (vl-position (car pair) requested)
                     (vl-position (car pair) '("CAD Filename" "Block Coords"))))
            (setq extra (cons (car pair) extra))
        )
    )

    (setq order (vl-remove nil
                    (append requested (reverse extra) '("CAD Filename" "Block Coords"))))

    (setq col 1)
    (foreach tag (mapcar '(lambda ( name ) (assoc name merged)) order)
        (if tag
            (progn
                (   (lambda ( row )
                        (vlax-put-property cells 'item row col (car tag))
                        (setq row (1+ row))
                        (foreach val (cdr tag)
                            (vlax-put-property cells 'item row col val)
                            (setq row (1+ row))
                        )
                    )
                    1
                )
                (setq col (1+ col))
            )
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:OrderTags
;;;
;;; Returns one block's tag entries in the order they should appear as
;;; columns.
;;;
;;; When specific tags were requested, that order is used and the coordinate
;;; column is appended; otherwise every tag found is written in the order it
;;; came out of the block.
;;;
;;;   blk    - (block-name (tag values) ...)
;;;   entry  - the request list for this block, or nil for "all tags"
;;;   coords - "1" if the coordinate column was requested
;;; ---------------------------------------------------------------------------

(defun AttHarvest:OrderTags ( blk entry coords )
    (if (cdr entry)
        (vl-remove nil
            (mapcar '(lambda ( name ) (assoc name (cdr blk)))
                (if (= "1" coords)
                    (append (cdr entry) '("Block Coords"))
                    (cdr entry)
                )
            )
        )
        (cdr blk)
    )
)

;;; ===========================================================================
;;;                    S U P P O R T   F U N C T I O N S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; AttHarvest:MergeAssoc
;;;
;;; Merges an association list so each key appears once, with all its values
;;; collected together in the order they were found.
;;;
;;; This is what turns twenty separate readings of the same block into one
;;; entry with twenty values per tag -- which is exactly the shape a
;;; spreadsheet column needs.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:MergeAssoc ( lst / found out )
    (setq out (list (car lst)))
    (while (setq lst (cdr lst))
        (setq out
            (if (setq found (assoc (caar lst) out))
                (subst (cons (car found) (append (cdr found) (cdar lst))) found out)
                (cons (car lst) out)
            )
        )
    )
    out
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:Unique
;;;
;;; Removes duplicates, keeping the first occurrence of each.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:Unique ( lst / item out )
    (while (setq item (car lst))
        (setq lst (vl-remove item lst)
              out (cons item out)
        )
    )
    (reverse out)
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:SortByFirst
;;;
;;; Sorts an association list by its keys.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:SortByFirst ( lst )
    (if lst (vl-sort lst '(lambda ( a b ) (< (car a) (car b)))))
)

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

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

;;; ---------------------------------------------------------------------------
;;; AttHarvest:ListUp / AttHarvest:ListDown
;;;
;;; Move every item at a listed position up or down one place, keeping the
;;; moved items in their relative order.
;;;
;;; The list is walked 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 walk advances, so they stay relative to
;;; the part of the list still to be processed -- which is what makes a block
;;; of adjacent selected items move as a block rather than collapsing.
;;;
;;; Moving down is moving up in a reversed list, so ListDown reverses the
;;; list, mirrors the indices to match, and reverses the result back.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:ListUp ( idx lst )
    (cond
        (   (or (null idx) (null lst)) lst)
        (   (= 0 (car idx))
            (cons (car lst) (AttHarvest:ListUp (cdr (mapcar '1- idx)) (cdr lst)))
        )
        (   (= 1 (car idx))
            (cons (cadr lst)
                  (AttHarvest:ListUp (cdr (mapcar '1- idx)) (cons (car lst) (cddr lst))))
        )
        (   (cons (car lst) (AttHarvest:ListUp (mapcar '1- idx) (cdr lst))))
    )
)

(defun AttHarvest:ListDown ( idx lst )
    (reverse
        (AttHarvest:ListUp
            (reverse (mapcar '(lambda ( n ) (- (1- (length lst)) n)) idx))
            (reverse lst)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:ToValue
;;;
;;; Turns a list of indices back into the space-separated string a
;;; multi-select list box expects.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:ToValue ( lst )
    (vl-string-trim "()" (vl-princ-to-string lst))
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:Join
;;;
;;; Joins a list of strings with a separator between each pair.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; AttHarvest:DocPath
;;;
;;; Returns a document's full path. A drawing that has never been saved has
;;; an empty FullName, so the path and name are assembled instead.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:DocPath ( doc )
    (if (= "" (vla-get-fullname doc))
        (strcat (vl-string-right-trim "\\" (vla-get-path doc)) "\\" (vla-get-name doc))
        (vla-get-fullname doc)
    )
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:DbxDocument
;;;
;;; Creates an ObjectDBX document object, or nil. The ProgID is
;;; version-stamped from AutoCAD 2004 (version 16) onward, so the major
;;; version number is read from ACADVER and appended.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:DbxDocument ( app / obj ver )
    (setq ver (atoi (getvar 'acadver))
          obj (vl-catch-all-apply 'vla-getinterfaceobject
                  (list app
                      (if (< ver 16)
                          "ObjectDBX.AxDbDocument"
                          (strcat "ObjectDBX.AxDbDocument." (itoa ver))
                      )
                  )
              )
    )
    (if (vl-catch-all-error-p obj)
        (progn (princ "\nUnable to interface with ObjectDBX.") nil)
        obj
    )
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:AllFiles
;;;
;;; Every file in a folder matching the filter, optionally including
;;; sub-folders at any depth.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:AllFiles ( dir subs filter / AttHarvest:SubFolders )

    ;; "." and ".." are removed by name rather than by position: their place
    ;; in the listing is not guaranteed, and descending into ".." would
    ;; recurse upwards forever.
    (defun AttHarvest:SubFolders ( folder / here )
        (apply 'append
            (mapcar
               '(lambda ( f )
                    (setq here (strcat folder "\\" f))
                    (cons here (AttHarvest:SubFolders here))
                )
                (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
            )
        )
    )

    (if (and dir (vl-file-directory-p (setq dir (AttHarvest:FixDir dir))))
        (apply 'append
            (mapcar
               '(lambda ( folder )
                    (mapcar '(lambda ( name ) (strcat folder "\\" name))
                            (vl-directory-files folder filter 1))
                )
                (cons dir (if subs (AttHarvest:SubFolders dir)))
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest: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 AttHarvest: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 (AttHarvest: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)
)

;;; ---------------------------------------------------------------------------
;;; AttHarvest:WriteConfig / AttHarvest:ReadConfig
;;;
;;; Save and reload the settings, one value per line. Values are written in
;;; printed form and read back with read, which round-trips strings, lists
;;; and nil faithfully -- the block and tag lists included.
;;;
;;; The read is forgiving: a short or hand-edited file leaves the remaining
;;; settings at their defaults rather than raising an error.
;;; ---------------------------------------------------------------------------

(defun AttHarvest:WriteConfig ( cfg lst / des )
    (if (setq des (open cfg "w"))
        (progn
            (foreach x lst (write-line (vl-prin1-to-string x) des))
            (close des)
            t
        )
    )
)

(defun AttHarvest:ReadConfig ( cfg syms / des line )
    (if (and (setq cfg (findfile cfg))
             (setq des (open cfg "r"))
        )
        (progn
            (foreach sym syms
                (if (setq line (read-line des))
                    (   (lambda ( val )
                            (if (not (vl-catch-all-error-p val)) (set sym val))
                        )
                        (vl-catch-all-apply 'read (list line))
                    )
                )
            )
            (close des)
            t
        )
    )
)

(princ "\nAttHarvest loaded. ATTPULL to extract attributes, ATTPUSH to write them.")
(princ)

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