;;; ---------------------------------------------------------------------------
;;; BlockTally.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; COUNT BLOCKS AND PRODUCE A SCHEDULE
;;;
;;; Counts every block in the drawing, or just the ones you select, and
;;; delivers the result as a real AutoCAD table, a text file, a CSV
;;; spreadsheet, or a listing at the command line.
;;;
;;; This is the door schedule, the fixture count, the furniture list -- the
;;; job that otherwise means selecting each symbol type in turn, reading the
;;; number off the status bar, and typing it into a table by hand.
;;;
;;; The table output is the interesting one. Alongside each block name and
;;; quantity it can place a live PREVIEW of the block itself, so the schedule
;;; shows what each symbol actually looks like. Anyone reading the drawing
;;; can match the schedule to the plan without a legend.
;;;
;;; ---------------------------------------------------------------------------
;;; WHAT GETS COUNTED
;;;
;;; Every block insertion, with two important refinements:
;;;
;;;   XREFS ARE EXCLUDED. An external reference is an insertion in the DXF
;;;   sense, but nobody wants "SITEPLAN.dwg x 1" in a fixture schedule. Xrefs
;;;   are identified from the block table and filtered out before counting.
;;;
;;;   DYNAMIC BLOCKS COUNT UNDER THEIR REAL NAME. A dynamic block whose
;;;   parameters have been changed is stored under an anonymous name such as
;;;   "*U47". Counting those literally would scatter one door type across
;;;   twenty meaningless entries. BlockTally traces each anonymous name back
;;;   to the definition it came from, so all twenty count as one door.
;;;
;;; ---------------------------------------------------------------------------
;;; OUTPUT FORMATS
;;;
;;;   TABLE         a real AutoCAD table placed in the drawing, using the
;;;                 current table style, optionally with block previews
;;;   TEXT FILE     tab-separated, for pasting into anything
;;;   CSV FILE      opens directly in Excel, using the list separator from
;;;                 your own Windows regional settings so it imports cleanly
;;;                 in every locale
;;;   COMMAND LINE  a formatted listing in the text window, with dot leaders,
;;;                 for a quick look without creating anything
;;;
;;; Headings, column titles, sort field and sort order are all configurable
;;; through BLOCKTALLYSET and are remembered between sessions.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW THE PREVIEW COLUMN WORKS
;;;
;;; A table cell can be told to display a block instead of text, by being
;;; given the object ID of that block's definition. BlockTally looks each
;;; block up in the drawing's block collection and hands the cell its ID,
;;; with auto-fit turned on so the preview scales itself to the cell.
;;;
;;; Object IDs are the one genuinely awkward part of the AutoCAD ActiveX
;;; interface: on 64-bit AutoCAD they do not fit in the integer type the
;;; original property returns. The program works out once which of the three
;;; possible retrieval methods this installation supports, then rewrites
;;; itself to use only that one.
;;;
;;; ---------------------------------------------------------------------------
;;;   BLOCKTALLY    - count blocks and produce the schedule
;;;   BLOCKTALLYSET - choose the output format, headings and sort order
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; Default settings, and the symbols they are stored under.
;;;
;;;   out  output format: "tab", "txt", "csv" or "com"
;;;   tg1  include the overall title row
;;;   tg2  include the block preview column
;;;   tg3  include the quantity column
;;;   ed1  overall title text
;;;   ed2  preview column heading
;;;   ed3  block name column heading
;;;   ed4  quantity column heading
;;;   srt  sort field: "blk" by name, "qty" by quantity
;;;   ord  sort order: "asc" or "des"
;;;
;;; These same symbol names are used as the configuration file keys, the
;;; dialog tile keys, and the variables the program reads -- which is what
;;; lets one list drive all three.
;;; ---------------------------------------------------------------------------

(setq *BlockTally:Defaults*
   '(
        (out "tab")
        (tg1 "1")
        (tg2 "1")
        (tg3 "1")
        (ed1 "Block Schedule")
        (ed2 "Preview")
        (ed3 "Block Name")
        (ed4 "Count")
        (srt "blk")
        (ord "asc")
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:FixDir
;;;
;;; Normalises a folder path: forward slashes become backslashes and any
;;; trailing backslash is removed, so paths can be concatenated without
;;; producing doubled separators.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; Location of the settings file.
;;;
;;; The AutoCAD Support folder is preferred: it is per-user, roams with the
;;; profile, and is never cleaned out. Falling back through the folder
;;; holding acad.pat to the temporary folder means the chain always succeeds,
;;; so no part of the program has to treat "nowhere to write" as a failure.
;;; ---------------------------------------------------------------------------

(setq *BlockTally:Config*
    (strcat
        (cond
            (   (getvar 'roamablerootprefix)
                (strcat (BlockTally:FixDir (getvar 'roamablerootprefix)) "\\Support")
            )
            (   (findfile "acad.pat")
                (BlockTally:FixDir (vl-filename-directory (findfile "acad.pat")))
            )
            (   (BlockTally:FixDir (vl-filename-directory (vl-filename-mktemp))))
        )
        "\\YZ_BlockTally.cfg"
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:Doc
;;;
;;; Returns the active document, caching itself after the first call.
;;; ---------------------------------------------------------------------------

(defun BlockTally:Doc nil
    (eval (list 'defun 'BlockTally:Doc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (BlockTally:Doc)
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:StartUndo / BlockTally:EndUndo
;;;
;;; Undo group control. EndUndo loops on bit 8 of UNDOCTL, so a group left
;;; open by an interrupted operation is also closed.
;;; ---------------------------------------------------------------------------

(defun BlockTally:EndUndo ( )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark (BlockTally:Doc))
    )
    (princ)
)

(defun BlockTally:StartUndo ( )
    (BlockTally:EndUndo)
    (vla-startundomark (BlockTally:Doc))
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:LoadSettings
;;;
;;; Reads the settings file, writing it first with the defaults if it is not
;;; there, then fills in any symbol the file did not supply.
;;;
;;; The values are assigned with set, which writes to whichever binding of
;;; that symbol is currently live. Because the calling command declares all
;;; ten as its own locals, the settings land in those locals and vanish when
;;; the command ends -- nothing is left in the global namespace.
;;; ---------------------------------------------------------------------------

(defun BlockTally:LoadSettings ( )
    (if (not (findfile *BlockTally:Config*))
        (BlockTally:WriteConfig *BlockTally:Config*
            (mapcar 'cadr *BlockTally:Defaults*)
        )
    )
    (BlockTally:ReadConfig *BlockTally:Config* (mapcar 'car *BlockTally:Defaults*))
    ;; Anything the file did not provide -- a truncated or hand-edited file --
    ;; falls back to its default rather than being left unbound.
    (foreach pair *BlockTally:Defaults*
        (if (not (boundp (car pair))) (apply 'set pair))
    )
    (princ)
)

;;; ===========================================================================
;;; BLOCKTALLY  -  count the blocks and produce the schedule
;;; ===========================================================================

(defun c:BlockTally

    ( /
        *error* BlockTally:Restore BlockTally:Line
        all col def des dir ed1 ed2 ed3 ed4 filt fnm hgt idx ins lst ord out
        row sel srt sortfn tab tg1 tg2 tg3 tmp vals vars xrefs
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; BlockTally:Restore
    ;;;
    ;;; Closes any open file, re-enables table regeneration, closes the undo
    ;;; group and restores system variables.
    ;;;
    ;;; Re-enabling regeneration matters: a table left with regeneration
    ;;; suppressed does not redraw when edited, and looks broken to anyone
    ;;; who touches it afterwards.
    ;;; -----------------------------------------------------------------------

    (defun BlockTally:Restore ( )
        (if (= 'file (type des)) (close des))
        (if (and (= 'vla-object (type tab))
                 (null (vlax-erased-p tab))
                 (= "AcDbTable" (vla-get-objectname tab))
                 (vlax-write-enabled-p tab)
                 (vlax-property-available-p tab 'regeneratetablesuppressed t)
            )
            (vla-put-regeneratetablesuppressed tab :vlax-false)
        )
        (BlockTally:EndUndo)
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; BlockTally:Line
    ;;;
    ;;; Prints one line to the text window.
    ;;; -----------------------------------------------------------------------

    (defun BlockTally:Line ( str )
        (princ "\n")
        (princ str)
    )

    (setvar 'cmdecho 0)
    (BlockTally:LoadSettings)

    ;; Tables need the AddTable method, which very old releases lack. Fall
    ;; back to a text file rather than failing.
    (if (and (= "tab" out)
             (not (vlax-method-applicable-p (vla-get-modelspace (BlockTally:Doc)) 'addtable))
        )
        (setq out "txt")
    )

    (BlockTally:StartUndo)

    ;; ---- build the selection filter ---------------------------------------
    ;; Bit 4 of DXF 70 on a block table record marks it as an xref. Every
    ;; such name is collected into a single comma-separated NOT filter, so
    ;; xrefs are excluded by the selection itself rather than being counted
    ;; and discarded afterwards.

    (while (setq tmp (tblnext "block" (null tmp)))
        (if (= 4 (logand 4 (cdr (assoc 70 tmp))))
            (setq xrefs (vl-list* "," (cdr (assoc 2 tmp)) xrefs))
        )
    )
    (if xrefs
        (setq filt (list '(0 . "INSERT") '(-4 . "<NOT")
                         (cons 2 (apply 'strcat (cdr xrefs)))
                        '(-4 . "NOT>")))
        (setq filt '((0 . "INSERT")))
    )

    (cond
        (   (null (setq all (ssget "_X" filt)))
            (princ "\nNo blocks were found in this drawing.")
        )

        ;;  A table cannot be created on a locked layer, and the failure
        ;;  would otherwise be silent.
        (   (and (= "tab" out)
                 (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            )
            (princ "\nThe current layer is locked - unlock it before creating a table.")
        )

        ;;  ---- choose what to count ----
        ;;  NOMUTT silences AutoCAD's own "Select objects:" prompt so the
        ;;  "<all>" hint is not scrolled away. Pressing Enter selects
        ;;  everything.
        (   (progn
                (setvar 'nomutt 1)
                (princ "\nSelect blocks to count <all>: ")
                (setq sel
                    (cond
                        (   (null (setq sel (vl-catch-all-apply 'ssget (list filt)))) all)
                        (   (null (vl-catch-all-error-p sel)) sel)
                    )
                )
                (setvar 'nomutt 0)
                (null sel)
            )
            (princ "\nNothing selected.")
        )

        ;;  ---- get the destination, then do the work ----
        (   (or (= "com" out)
                (and (=  "tab" out) (setq ins (getpoint "\nSpecify point for table: ")))
                (and (/= "tab" out)
                    (setq fnm
                        (getfiled "Create output file"
                            ;; Reopen in the last folder used, which is
                            ;; usually where the next one belongs too.
                            (cond
                                (   (and (setq dir (getenv "YZ\\BlockTallyDir"))
                                         (vl-file-directory-p (setq dir (BlockTally:FixDir dir)))
                                    )
                                    (strcat dir "\\")
                                )
                                (   (getvar 'dwgprefix))
                            )
                            out 1
                        )
                    )
                )
            )

            ;; ---- count ---------------------------------------------------
            (repeat (setq idx (sslength sel))
                (setq lst (BlockTally:Increment
                              (BlockTally:RealName (ssname sel (setq idx (1- idx))))
                              lst
                          )
                )
            )

            ;; ---- sort ----------------------------------------------------
            ;; The comparison is built as a lambda at run time so that field
            ;; and direction are both baked in, rather than being retested
            ;; for every one of the many comparisons a sort performs.
            (if (= "blk" srt)
                (setq sortfn (eval (list 'lambda '( a b )
                                 (list (if (= "asc" ord) '< '>)
                                       '(strcase (car a)) '(strcase (car b))))))
                (setq sortfn (eval (list 'lambda '( a b )
                                 (list (if (= "asc" ord) '< '>) '(cdr a) '(cdr b)))))
            )
            (setq lst (vl-sort lst 'sortfn))

            (cond
                ;;  ============ command line listing ============
                (   (= "com" out)
                    (BlockTally:Line (BlockTally:Pad "" "" "=" 60))
                    (if (= "1" tg1)
                        (progn
                            (BlockTally:Line ed1)
                            (BlockTally:Line (BlockTally:Pad "" "" "-" 60))
                        )
                    )
                    (BlockTally:Line (BlockTally:Pad ed3 ed4 " " 55))
                    (BlockTally:Line (BlockTally:Pad "" "" "-" 60))
                    (if (= "1" tg3)
                        ;; Dot leaders make a long list readable across the
                        ;; gap between name and number.
                        (foreach itm lst
                            (BlockTally:Line (BlockTally:Pad (car itm) (itoa (cdr itm)) "." 55))
                        )
                        (foreach itm lst (BlockTally:Line (car itm)))
                    )
                    (BlockTally:Line (BlockTally:Pad "" "" "=" 60))
                    (textpage)
                )

                ;;  ============ AutoCAD table ============
                (   (= "tab" out)
                    (if (= "1" tg3)
                        (setq lst (mapcar '(lambda ( x ) (list (car x) (itoa (cdr x)))) lst))
                        (setq lst (mapcar '(lambda ( x ) (list (car x))) lst))
                    )

                    ;; Row height and column width are derived from the
                    ;; current table style's own text height, so the table
                    ;; comes out proportioned like every other table in the
                    ;; drawing whatever the drawing scale.
                    (setq hgt
                        (   (lambda ( h ) (if (and (= 'real (type h)) (< 0 h)) h 2.5))
                            (   (lambda ( r ) (if (vl-catch-all-error-p r) nil r))
                                (vl-catch-all-apply 'vla-gettextheight
                                    (list
                                        (vla-item
                                            (vla-item (vla-get-dictionaries (BlockTally:Doc))
                                                      "acad_tablestyle")
                                            (getvar 'ctablestyle)
                                        )
                                        acdatarow
                                    )
                                )
                            )
                        )
                    )

                    (setq tab
                        (vla-addtable
                            (vlax-get-property (BlockTally:Doc)
                                (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                            (vlax-3d-point (trans ins 1 0))
                            ;; Rows: one per block, plus a title row and a
                            ;; heading row.
                            (+ (length lst) 2)
                            ;; Columns: the name column always, plus preview
                            ;; and quantity if they are switched on.
                            (+ 1 (atoi tg2) (atoi tg3))
                            (* 2.5 hgt)
                            ;; Column width from the longest string that has
                            ;; to fit in it, with the title row taken into
                            ;; account by dividing its length across the
                            ;; columns it will span.
                            (* hgt
                                (max
                                    (apply 'max
                                        (mapcar 'strlen
                                            (append
                                                (if (= "1" tg2) (list ed2))
                                                (if (= "1" tg3) (list ed4))
                                                (cons ed3 (apply 'append lst))
                                            )
                                        )
                                    )
                                    (if (= "1" tg1)
                                        (/ (strlen ed1) (+ 1 (atoi tg2) (atoi tg3)))
                                        0
                                    )
                                )
                            )
                        )
                    )

                    ;; Regeneration is suppressed while the table is filled.
                    ;; Without this AutoCAD recalculates the whole layout
                    ;; after every single cell, which on a long schedule
                    ;; takes minutes rather than moments.
                    (if (vlax-property-available-p tab 'regeneratetablesuppressed t)
                        (vla-put-regeneratetablesuppressed tab :vlax-true)
                    )
                    (vla-put-stylename tab (getvar 'ctablestyle))

                    ;; Heading row. Only the enabled columns are written, and
                    ;; the column counter advances only for those, so the
                    ;; headings line up with the data whichever combination
                    ;; is switched on.
                    (setq col 0)
                    (mapcar
                       '(lambda ( on txt )
                            (if (= "1" on)
                                (progn (vla-settext tab 1 col txt) (setq col (1+ col)))
                            )
                        )
                        (list tg2 "1" tg3)
                        (list ed2 ed3 ed4)
                    )

                    ;; Data rows.
                    (setq row 2)
                    (foreach itm lst
                        (if (= "1" tg2)
                            ;; Preview cell first, then the text columns
                            ;; follow it.
                            (BlockTally:PreviewCell tab row (setq col 0) (car itm))
                            ;; No preview: start at -1 so the first increment
                            ;; lands on column 0.
                            (setq col -1)
                        )
                        (foreach txt itm
                            (vla-settext tab row (setq col (1+ col)) txt)
                        )
                        (setq row (1+ row))
                    )

                    ;; The title row was created unconditionally because the
                    ;; row count had to be fixed at creation time; it is
                    ;; deleted again if it is not wanted.
                    (if (= "1" tg1)
                        (vla-settext tab 0 0 ed1)
                        (vla-deleterows tab 0 1)
                    )
                    (princ (strcat "\n" (itoa (length lst)) " block"
                                   (if (= 1 (length lst)) "" "s") " scheduled."))
                )

                ;;  ============ text or CSV file ============
                (   t
                    (setenv "YZ\\BlockTallyDir" (BlockTally:FixDir (vl-filename-directory fnm)))
                    (if
                        (   (if (= "txt" out) BlockTally:WriteTxt BlockTally:WriteCsv)
                            (append
                                (if (= "1" tg1) (list (list ed1)))
                                (if (= "1" tg3)
                                    (cons (list ed3 ed4)
                                          (mapcar '(lambda ( x ) (list (car x) (itoa (cdr x)))) lst))
                                    (cons (list ed3)
                                          (mapcar '(lambda ( x ) (list (car x))) lst))
                                )
                            )
                            fnm
                        )
                        (princ (strcat "\n" (itoa (length lst)) " block"
                                       (if (= 1 (length lst)) "" "s")
                                       " written to " fnm))
                        (alert
                            (strcat "The output file could not be created:\n\n" fnm
                                    "\n\nCheck that you have write permission for that folder, "
                                    "and that the file is not already open.")
                        )
                    )
                )
            )
        )

        (   t (princ "\nCancelled."))
    )

    (BlockTally:Restore)
    (princ)
)

;;; ===========================================================================
;;; BLOCKTALLYSET  -  choose output format, headings and sort order
;;; ===========================================================================

(defun c:BlockTallySet

    ( /
        *error* dch dcl des ed1 ed2 ed3 ed4 ord out setout settg1 settg2 settg3
        srt tg1 tg2 tg3 vals vars
    )

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

    (defun *error* ( msg )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (mapcar 'setvar vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BLOCKTALLYSET error: " msg " **"))
        )
        (princ)
    )

    (setvar 'cmdecho 0)
    (BlockTally:LoadSettings)

    (cond
        ;;  The dialog is written to a uniquely named temporary file, loaded,
        ;;  and deleted on exit. A unique name means two AutoCAD sessions
        ;;  cannot collide over it, and nothing is left in the support folder.
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line
                           '(
                                "// Shared tile shapes, so the columns line up."
                                "b15 : edit_box"
                                "{"
                                "    edit_width = 16; edit_limit = 1024;"
                                "    fixed_width = true; alignment = centered;"
                                "    horizontal_margin = none; vertical_margin = none;"
                                "}"
                                "b30 : edit_box"
                                "{"
                                "    edit_width = 52; edit_limit = 1024;"
                                "    fixed_width = true; alignment = centered;"
                                "    horizontal_margin = none; vertical_margin = none;"
                                "}"
                                "tog : toggle { vertical_margin = none; horizontal_margin = 0.2; }"
                                "rwo : row       { fixed_width = true; alignment = centered; }"
                                "rrw : radio_row { fixed_width = true; alignment = centered; }"
                                ""
                                "dia : dialog"
                                "{"
                                "    key = \"dcl\";"
                                "    spacer_1;"
                                "    : boxed_column"
                                "    {"
                                "        label = \"Output\";"
                                "        : rrw"
                                "        {"
                                "            : radio_button { key = \"tab\"; label = \"Table\"; }"
                                "            : radio_button { key = \"txt\"; label = \"Text File\"; }"
                                "            : radio_button { key = \"csv\"; label = \"CSV File\"; }"
                                "            : radio_button { key = \"com\"; label = \"Command line\"; }"
                                "        }"
                                "        spacer;"
                                "    }"
                                "    : boxed_column"
                                "    {"
                                "        label = \"Headings\";"
                                "        spacer_1;"
                                "        : rwo"
                                "        {"
                                "            : tog { key = \"tg1\"; }"
                                "            : b30 { key = \"ed1\"; }"
                                "            : spacer { fixed_width = true; vertical_margin = none; width = 2.5; }"
                                "        }"
                                "        : rwo"
                                "        {"
                                "            spacer;"
                                "            : tog { key = \"tg2\"; }"
                                "            : b15 { key = \"ed2\"; }"
                                "            : b15 { key = \"ed3\"; }"
                                "            : b15 { key = \"ed4\"; }"
                                "            : tog { key = \"tg3\"; }"
                                "            spacer;"
                                "        }"
                                "        spacer_1;"
                                "    }"
                                "    : row"
                                "    {"
                                "        : boxed_column"
                                "        {"
                                "            label = \"Sort By\";"
                                "            : rrw"
                                "            {"
                                "                : radio_button { key = \"blk\"; label = \"Block Name\"; }"
                                "                : radio_button { key = \"qty\"; label = \"Quantity\"; }"
                                "            }"
                                "            spacer;"
                                "        }"
                                "        : boxed_column"
                                "        {"
                                "            label = \"Sort Order\";"
                                "            : rrw"
                                "            {"
                                "                : radio_button { key = \"asc\"; label = \"Ascending\"; }"
                                "                : radio_button { key = \"des\"; label = \"Descending\"; }"
                                "            }"
                                "            spacer;"
                                "        }"
                                "    }"
                                "    spacer_1; ok_cancel;"
                                "}"
                            )
                            (write-line line des)
                        )
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                    (new_dialog "dia" dch)
                )
            )
            (princ "\nUnable to create the settings dialog.")
        )

        (   t
            (set_tile "dcl" "Block Tally Settings")

            ;; Tables are unavailable on very old releases; grey the option
            ;; out rather than letting the user choose something that cannot
            ;; work.
            (if (and (= "tab" out)
                     (not (vlax-method-applicable-p
                              (vla-get-modelspace (BlockTally:Doc)) 'addtable))
                )
                (progn (mode_tile "tab" 1) (setq out "txt"))
            )

            ;; ---- toggles -------------------------------------------------
            ;; Each toggle both records its state and enables or greys the
            ;; edit box beside it, so the dialog shows at a glance which
            ;; headings will actually appear. The helper is called once
            ;; immediately to set the initial state, and then from the
            ;; callback.
            (setq settg1 (lambda ( val ) (mode_tile "ed1" (- 1 (atoi (setq tg1 val))))))
            (set_tile "tg1" tg1) (settg1 tg1)
            (action_tile "tg1" "(settg1 $value)")

            (setq settg2 (lambda ( val ) (mode_tile "ed2" (- 1 (atoi (setq tg2 val))))))
            (set_tile "tg2" tg2) (settg2 tg2)
            (action_tile "tg2" "(settg2 $value)")

            (setq settg3 (lambda ( val ) (mode_tile "ed4" (- 1 (atoi (setq tg3 val))))))
            (set_tile "tg3" tg3) (settg3 tg3)
            (action_tile "tg3" "(settg3 $value)")

            ;; ---- heading text boxes --------------------------------------
            ;; The tile key and the variable name are deliberately the same
            ;; string, so one loop can both fill the tile and build its
            ;; callback.
            (foreach key '("ed1" "ed2" "ed3" "ed4")
                (set_tile key (eval (read key)))
                (action_tile key (strcat "(setq " key " $value)"))
            )

            ;; ---- output format -------------------------------------------
            ;; The preview column only means anything in a table, so it is
            ;; greyed out for the file and command-line formats.
            (set_tile out "1")
            (setq setout
                (lambda ( val )
                    (if (= "tab" (setq out val))
                        (progn
                            (mode_tile "tg2" 0)
                            (mode_tile "ed2" (- 1 (atoi tg2)))
                        )
                        (progn
                            (mode_tile "tg2" 1)
                            (mode_tile "ed2" 1)
                        )
                    )
                )
            )
            (setout out)
            (foreach key '("tab" "txt" "csv" "com")
                (action_tile key "(setout $key)")
            )

            ;; ---- sort field and order ------------------------------------
            (set_tile srt "1")
            (foreach key '("blk" "qty") (action_tile key "(setq srt $key)"))
            (set_tile ord "1")
            (foreach key '("asc" "des") (action_tile key "(setq ord $key)"))

            (if (= 1 (start_dialog))
                (progn
                    (BlockTally:WriteConfig *BlockTally:Config*
                        (mapcar 'eval (mapcar 'car *BlockTally:Defaults*))
                    )
                    (princ "\nBlockTally settings saved.")
                )
                (princ "\nCancelled.")
            )
        )
    )

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

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

;;; ---------------------------------------------------------------------------
;;; BlockTally:ToString
;;;
;;; Converts a value to text for the configuration file.
;;;
;;; Reals are written with fifteen decimal places and DIMZIN temporarily set
;;; to 8, which suppresses trailing zeros. Without that a value would come
;;; back from the file slightly changed by the drawing's current precision
;;; setting.
;;; ---------------------------------------------------------------------------

(defun BlockTally:ToString ( arg / zin )
    (cond
        (   (= 'int  (type arg)) (itoa arg))
        (   (= 'real (type arg))
            (setq zin (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq arg (rtos arg 2 15))
            (setvar 'dimzin zin)
            arg
        )
        (   (vl-prin1-to-string arg))
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:WriteConfig / BlockTally: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 and numbers faithfully. The read is forgiving: a
;;; short or hand-edited file simply leaves the remaining settings at their
;;; defaults.
;;; ---------------------------------------------------------------------------

(defun BlockTally:WriteConfig ( cfg lst / des )
    (if (setq des (open cfg "w"))
        (progn
            (foreach itm lst (write-line (BlockTally:ToString itm) des))
            (close des)
            t
        )
    )
)

(defun BlockTally: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
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:WriteCsv
;;;
;;; Writes the schedule as a CSV file.
;;;
;;; The separator is read from the user's own Windows regional settings
;;; rather than assumed to be a comma. In much of Europe the list separator
;;; is a semicolon, and a comma-separated file opens there as a single
;;; unusable column.
;;; ---------------------------------------------------------------------------

(defun BlockTally:WriteCsv ( lst csv / des sep )
    (if (setq des (open csv "w"))
        (progn
            (setq sep
                (cond
                    (   (vl-registry-read
                            "HKEY_CURRENT_USER\\Control Panel\\International" "sList"))
                    (   ",")
                )
            )
            (foreach row lst (write-line (BlockTally:RowToCsv row sep) des))
            (close des)
            t
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:RowToCsv
;;;
;;; Joins one row of values with the separator, quoting where necessary.
;;; ---------------------------------------------------------------------------

(defun BlockTally:RowToCsv ( lst sep )
    (if (cdr lst)
        (strcat (BlockTally:CsvQuote (car lst) sep) sep
                (BlockTally:RowToCsv (cdr lst) sep))
        (BlockTally:CsvQuote (car lst) sep)
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:CsvQuote
;;;
;;; Wraps a value in quotes if it contains the separator or a quote, and
;;; doubles any quotes inside it -- the standard CSV escaping rules.
;;;
;;; A block genuinely named "DOOR, SINGLE" would otherwise split into two
;;; columns and shift every subsequent value along by one.
;;;
;;; The separator is backquote-escaped inside the wcmatch pattern, because it
;;; could itself be a wildcard character.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; BlockTally:WriteTxt
;;;
;;; Writes the schedule as a tab-separated text file, which pastes cleanly
;;; into a spreadsheet or a word processor table.
;;; ---------------------------------------------------------------------------

(defun BlockTally:WriteTxt ( lst txt / des )
    (if (setq des (open txt "w"))
        (progn
            (foreach row lst (write-line (BlockTally:RowToStr row "\t") des))
            (close des)
            t
        )
    )
)

(defun BlockTally:RowToStr ( lst del )
    (if (cdr lst)
        (strcat (car lst) del (BlockTally:RowToStr (cdr lst) del))
        (car lst)
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:Pad
;;;
;;; Returns s1 and s2 separated by enough fill characters to make the whole
;;; thing the given length -- the dot leaders in the command-line listing.
;;;
;;; Working in character codes rather than strings means one repeat loop
;;; builds the fill, instead of a strcat per character.
;;;
;;;   s1 - text on the left
;;;   s2 - text on the right
;;;   ch - single-character fill string
;;;   ln - total length
;;; ---------------------------------------------------------------------------

(defun BlockTally:Pad ( s1 s2 ch ln )
    (   (lambda ( fill left right )
            (repeat (- ln (length left) (length right))
                (setq right (cons fill right))
            )
            (vl-list->string (append left right))
        )
        (ascii ch)
        (vl-string->list s1)
        (vl-string->list s2)
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:PreviewCell
;;;
;;; Turns a table cell into a live preview of a block.
;;;
;;; The cell is given the object ID of the block DEFINITION, with auto-fit
;;; enabled so the preview scales itself to the cell rather than overflowing
;;; it.
;;;
;;; Which method name exists depends on the release -- the 32-suffixed
;;; variant was added for 64-bit object IDs. The test is done once and the
;;; function then rewrites itself with the correct call and the block
;;; collection already resolved, so neither is looked up again.
;;; ---------------------------------------------------------------------------

(defun BlockTally:PreviewCell ( tab row col blk )
    (eval
        (list 'defun 'BlockTally:PreviewCell '( tab row col blk )
            (cons
                (if (vlax-method-applicable-p tab 'setblocktablerecordid32)
                    'vla-setblocktablerecordid32
                    'vla-setblocktablerecordid
                )
                (list 'tab 'row 'col
                    (list 'BlockTally:ObjectId
                        (list 'vla-item (vla-get-blocks (BlockTally:Doc)) 'blk)
                    )
                    ':vlax-true          ;; auto-fit the preview to the cell
                )
            )
        )
    )
    (BlockTally:PreviewCell tab row col blk)
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:ObjectId
;;;
;;; Returns an object's ID in a form the table methods accept.
;;;
;;; There are three cases and they are genuinely different:
;;;   * 32-bit AutoCAD    the plain ObjectId property fits in an integer
;;;   * newer 64-bit      ObjectId32 exists and returns a usable value
;;;   * older 64-bit      neither works; the ID has to be fetched as a string
;;;                       through the Utility object
;;;
;;; The right case is determined once and the function rewrites itself to use
;;; only that call.
;;; ---------------------------------------------------------------------------

(defun BlockTally:ObjectId ( obj )
    (eval
        (list 'defun 'BlockTally:ObjectId '( obj )
            (cond
                (   (not (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*"))
                   '(vla-get-objectid obj)
                )
                (   (= 'subr (type vla-get-objectid32))
                   '(vla-get-objectid32 obj)
                )
                (   (list 'vla-getobjectidstring
                          (vla-get-utility (BlockTally:Doc)) 'obj ':vlax-false)
                )
            )
        )
    )
    (BlockTally:ObjectId obj)
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:Increment
;;;
;;; Adds one to the count for a key in an association list, creating the
;;; entry if it is not there yet.
;;;
;;; An association list is used rather than a growing list of names because
;;; the count is then a single subst rather than a re-scan, which matters on
;;; a drawing holding tens of thousands of insertions.
;;; ---------------------------------------------------------------------------

(defun BlockTally:Increment ( key lst / itm )
    (if (setq itm (assoc key lst))
        (subst (cons key (1+ (cdr itm))) itm lst)
        (cons  (cons key 1) lst)
    )
)

;;; ---------------------------------------------------------------------------
;;; BlockTally:RealName
;;;
;;; Returns the name a block should be counted under.
;;;
;;; A dynamic block whose parameters have been changed is stored under an
;;; anonymous name beginning with an asterisk, such as "*U47". Counting those
;;; literally would scatter one door type across dozens of meaningless
;;; entries.
;;;
;;; The route back to the real name goes through the anonymous block's owner,
;;; which carries extended data under "AcDbBlockRepBTag". Group 1005 of that
;;; data is the HANDLE of the original dynamic block definition, and its
;;; group 2 is the name the user recognises.
;;;
;;; This works purely on entity data, with no ActiveX call, which makes it
;;; markedly faster than reading EffectiveName once per insertion -- the
;;; difference is measurable on a drawing with thousands of blocks.
;;;
;;;   ent - block reference entity name
;;; ---------------------------------------------------------------------------

(defun BlockTally:RealName ( ent / blk rep )
    ;; "`**" matches a name whose first character is a literal asterisk.
    (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
        (if (and (setq rep
                     (cdadr
                         (assoc -3
                             (entget
                                 (cdr (assoc 330 (entget (tblobjname "block" blk))))
                                '("AcDbBlockRepBTag")
                             )
                         )
                     )
                 )
                 (setq rep (handent (cdr (assoc 1005 rep))))
            )
            (setq blk (cdr (assoc 2 (entget rep))))
        )
    )
    blk
)

(princ "\nBlockTally loaded. BLOCKTALLY to count blocks, BLOCKTALLYSET for options.")
(princ)

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