;;; ---------------------------------------------------------------------------
;;; TagTotal.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Totals the numeric values held in block attributes, grouped by attribute
;;; TAG, and writes the results into an AutoCAD table.
;;;
;;; Select a drawing full of attributed blocks and you get a schedule: each tag
;;; that holds numbers, and the sum of all its values. Quantities, weights,
;;; lengths, loadings - anything recorded as an attribute becomes a total
;;; without anyone opening a calculator.
;;;
;;; Attributes whose values are not numeric are ignored, so descriptive tags
;;; like DESCRIPTION or ROOM_NAME simply do not appear.
;;;
;;; CONSTANT ATTRIBUTES ARE INCLUDED
;;; GetAttributes returns only variable attributes, so GetConstantAttributes is
;;; called as well - otherwise a fixed value visible in the drawing would be
;;; silently left out of the total.
;;;
;;; THE TOTALS ARE LIVE BY DEFAULT
;;; With TagTotal:UseFields set to T, the table cells contain field expressions
;;; that reference the attributes themselves, so editing any attribute value
;;; updates the table automatically.
;;;
;;; The limits of that are worth knowing: the fields reference the specific
;;; attributes present when the table was built. ADDING new blocks afterwards
;;; will not change the totals, and DELETING a referenced block leaves a broken
;;; reference in the sum. Rebuild the table when the drawing's content changes.
;;;
;;; Set TagTotal:UseFields to nil for plain static numbers instead.
;;;
;;;   TAGTOTAL  - total attribute values into a table
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; SETTINGS
;;; ---------------------------------------------------------------------------

(setq TagTotal:Title    nil)              ; table title, or nil for none
(setq TagTotal:Headings '("Tag" "Total")) ; column headings
(setq TagTotal:UseFields t)               ; T for live fields, nil for static
(setq TagTotal:Format   "%lu6")           ; field formatting when live

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

;; ---------------------------------------------------------------------------
;; TagTotal:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string, using GetObjectIdString where available.
;; The test runs once, then this function replaces itself.
;; ---------------------------------------------------------------------------
(defun TagTotal:ObjectID ( obj )
    (eval
        (list 'defun 'TagTotal:ObjectID '( obj )
            (if (vlax-method-applicable-p (vla-get-utility (TagTotal:Doc)) 'getobjectidstring)
                (list 'vla-getobjectidstring
                      (vla-get-utility (TagTotal:Doc)) 'obj ':vlax-false
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (TagTotal:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; TagTotal:Accumulate
;; ---------------------------------------------------------------------------
;; Adds a value to a tag's list of contributions, creating the entry if needed.
;;
;; Each entry becomes (tag value value value ...) - the individual values are
;; kept rather than being summed immediately, because in field mode each one
;; must appear separately in the expression.
;; ---------------------------------------------------------------------------
(defun TagTotal:Accumulate ( key val lst / itm )
    (if (setq itm (assoc key lst))
        (subst (vl-list* key val (cdr itm)) itm lst)
        (cons  (list key val) lst)
    )
)

;; ---------------------------------------------------------------------------
;; TagTotal:Annotative
;; ---------------------------------------------------------------------------
;; True if the named text style is annotative.
;;
;; The flag is not a plain property - it lives in the style's extended data
;; under "AcadAnnotative", as group 1070 with value 1.
;; ---------------------------------------------------------------------------
(defun TagTotal:Annotative ( sty )
    (and (setq sty (tblobjname "style" sty))
         (setq sty (cadr (assoc -3 (entget sty '("acadannotative")))))
         (= 1 (cdr (assoc 1070 (reverse sty))))
    )
)

;; ---------------------------------------------------------------------------
;; TagTotal:TextWidth
;; ---------------------------------------------------------------------------
;; Returns the plotted width a string needs in a table cell.
;;
;; A string containing a FIELD cannot be measured directly - the expression is
;; far longer than the value it will display, so measuring it would produce an
;; absurdly wide column. So a temporary TEXT object is created holding the
;; field, which forces AutoCAD to evaluate it, and the RESULT is measured
;; instead. The temporary object is then removed.
;;
;; Two and a half text heights are added for cell padding.
;; ---------------------------------------------------------------------------
(defun TagTotal:TextWidth ( str hgt sty / box obj tmp )
    (if (and (wcmatch str "*%<*>%*")
             (setq tmp
                 (entmakex
                     (list '(00 . "TEXT")
                           '(10 0.0 0.0 0.0)
                            (cons 01 str)
                            (cons 40 hgt)
                            (cons 07 sty)
                     )
                 )
             )
        )
        (progn
            (setq obj (vlax-ename->vla-object tmp))
            ;; Cleared and rewritten to force the field to evaluate.
            (vla-put-textstring obj "")
            (vla-put-textstring obj str)
            (setq str (vla-get-textstring obj))
            (entdel tmp)
        )
    )
    (if (setq box (textbox (list (cons 01 str) (cons 40 hgt) (cons 07 sty))))
        (+ (* 2.5 hgt) (- (caadr box) (caar box)))
        0.0
    )
)

;; ---------------------------------------------------------------------------
;; TagTotal:ListBox
;; ---------------------------------------------------------------------------
;; Multi-select list, returning the chosen strings or nil. The dialog name
;; "tagtotal" must match between the DCL text and the new_dialog call.
;; ---------------------------------------------------------------------------
(defun TagTotal:ListBox ( msg lst / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "tagtotal:dialog{label=\"" msg "\";spacer;"
                                ":list_box{key=\"list\";multiple_select=true;width=50;height=15;}"
                                "spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "tagtotal" dch)
                )
            )
            (princ "\nThe tag selection dialog could not be created.")
        )
        (   t
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (mapcar (function (lambda ( n ) (nth n lst))) (read (strcat "(" rtn ")")))
                )
            )
        )
    )
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

;; ---------------------------------------------------------------------------
;; TagTotal:AddTable
;; ---------------------------------------------------------------------------
;; Builds a table at the given point from a matrix of cell strings.
;;
;; Column widths are computed per column from the widest entry in it, so the
;; table fits its content rather than using an arbitrary default. If a title is
;; supplied and is wider than the columns together, the excess is shared out
;; evenly between them.
;;
;; Regeneration is suppressed while the cells are filled and re-enabled
;; afterwards - a table regenerating after every single cell write is
;; dramatically slower on anything but the smallest schedule.
;;
;; spc - [vla-object] model or paper space
;; ins - [list] WCS insertion point
;; ttl - [str] title, or nil
;; lst - [list] rows of cell strings, first row being the headings
;; eqc - [boolean] T to force all columns to equal width
;; ---------------------------------------------------------------------------
(defun TagTotal:AddTable ( spc ins ttl lst eqc / dif hgt i j obj stn sty wid )

    (setq sty
        (vlax-ename->vla-object
            (cdr (assoc -1
                (dictsearch
                    (cdr (assoc -1 (dictsearch (namedobjdict) "acad_tablestyle")))
                    (getvar 'ctablestyle)
                )
            ))
        )
    )
    (setq hgt (vla-gettextheight sty acdatarow)
          stn (vla-gettextstyle  sty acdatarow)
    )

    ;; An annotative style reports its PLOTTED height, so it must be divided by
    ;; the annotation scale to give the model-space height.
    (if (TagTotal:Annotative stn)
        (setq hgt (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0))))
    )

    ;; Widest entry per column. Transposing the matrix groups the cells by
    ;; column rather than by row.
    (setq wid
        (mapcar
            (function
                (lambda ( col )
                    (apply 'max
                        (mapcar (function (lambda ( str ) (TagTotal:TextWidth str hgt stn))) col)
                    )
                )
            )
            (apply 'mapcar (cons 'list lst))
        )
    )

    ;; Widen the columns if the title would not otherwise fit.
    (if (and ttl
             (< 0.0 (setq dif (/ (- (TagTotal:TextWidth ttl hgt stn) (apply '+ wid))
                                 (length wid)
                              )
                    )
             )
        )
        (setq wid (mapcar (function (lambda ( x ) (+ x dif))) wid))
    )

    (setq obj
        (vla-addtable spc
            (vlax-3D-point ins)
            (1+ (length lst))
            (length (car lst))
            (* 2.0 hgt)
            (if eqc
                (apply 'max wid)
                (/ (apply '+ wid) (float (length (car lst))))
            )
        )
    )

    (vla-put-regeneratetablesuppressed obj :vlax-true)
    (vla-put-stylename obj (getvar 'ctablestyle))

    (setq i -1)
    (if (null eqc)
        (foreach col wid
            (vla-setcolumnwidth obj (setq i (1+ i)) col)
        )
    )

    ;; A table is created with a title row; if no title was supplied that row
    ;; is deleted and the data starts one row higher.
    (if ttl
        (progn (vla-settext obj 0 0 ttl) (setq i 1))
        (progn (vla-deleterows obj 0 1)  (setq i 0))
    )

    (foreach row lst
        (setq j 0)
        (foreach val row
            (vla-settext obj i j val)
            (setq j (1+ j))
        )
        (setq i (1+ i))
    )

    (vla-put-regeneratetablesuppressed obj :vlax-false)
    obj
)

;; ---------------------------------------------------------------------------
;; TagTotal:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt, restoring NOMUTT to its captured value.
;; ---------------------------------------------------------------------------
(defun TagTotal:Ssget ( msg arg / mutt sel )
    (princ msg)
    (setq mutt (getvar 'nomutt))
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt mutt)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; ---------------------------------------------------------------------------
;; c:TAGTOTAL  -  main routine
;; ---------------------------------------------------------------------------
(defun c:TAGTOTAL ( / *error* vars vals space sel idx obj val lst tags ins rows )

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

    (defun TagTotal:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

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

    (setvar "CMDECHO" 0)

    (setq space
        (if (= 1 (getvar 'cvport))
            (vla-get-paperspace (TagTotal:Doc))
            (vla-get-modelspace (TagTotal:Doc))
        )
    )

    (cond
        (   (not (vlax-method-applicable-p space 'addtable))
            (princ "\nThis AutoCAD version does not support table objects.")
        )

        ;; The table is created on the current layer, so it must be unlocked.
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            (princ "\nThe current layer is locked - unlock it before running this.")
        )

        (   (not (setq sel (TagTotal:Ssget "\nSelect attributed blocks: " '(((0 . "INSERT"))))))
            (princ "\nNothing selected.")
        )

        (   (progn
                ;; Gather the values. In field mode each contribution is the
                ;; field expression referencing that attribute; otherwise it is
                ;; the number itself.
                (repeat (setq idx (sslength sel))
                    (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                    (foreach att (append (vlax-invoke obj 'getattributes)
                                         (vlax-invoke obj 'getconstantattributes)
                                 )
                        ;; distof returns nil for non-numeric text, which is how
                        ;; descriptive attributes are filtered out.
                        (if (setq val (distof (vla-get-textstring att)))
                            (setq lst
                                (TagTotal:Accumulate
                                    (strcase (vla-get-tagstring att))
                                    (if TagTotal:UseFields
                                        (strcat "+%<\\AcObjProp Object(%<\\_ObjId "
                                                (TagTotal:ObjectID att)
                                                ">%).TextString>%"
                                        )
                                        val
                                    )
                                    lst
                                )
                            )
                        )
                    )
                )
                (null (setq lst (vl-sort lst (function (lambda ( a b ) (< (car a) (car b)))))))
            )
            (princ "\nNo numeric attribute values found in that selection.")
        )

        (   (and
                ;; Only ask which tags to include when there is more than one.
                (setq tags (if (cdr lst)
                               (TagTotal:ListBox "Select Tags to Display" (mapcar 'car lst))
                               (mapcar 'car lst)
                           )
                )
                (setq ins (getpoint "\nSpecify point for the table: "))
            )
            ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
            ;; unless the routine says up front that it will use one. Restore does,
            ;; to close this undo group. The declaring call is absent on older
            ;; releases, so it is wrapped rather than tested for.
            (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
            (command "_.UNDO" "_Begin")

            ;; Build the rows. In field mode the individual field expressions
            ;; are concatenated into one arithmetic field; the substr from
            ;; position 2 drops the leading "+" that each contribution carries.
            (setq rows
                (mapcar
                    (function
                        (lambda ( x )
                            (if TagTotal:UseFields
                                (list (car x)
                                      (strcat "%<\\AcExpr "
                                              (substr (apply 'strcat (cdr x)) 2)
                                              " \\f \"" TagTotal:Format "\">%"
                                      )
                                )
                                (list (car x) (rtos (apply '+ (cdr x))))
                            )
                        )
                    )
                    (vl-remove-if-not
                        (function (lambda ( x ) (member (car x) tags)))
                        lst
                    )
                )
            )

            (TagTotal:AddTable space (trans ins 1 0) TagTotal:Title
                (cons TagTotal:Headings rows)
                nil
            )

            (princ (strcat "\nTable created for " (itoa (length rows))
                           " tag" (if (= 1 (length rows)) "" "s") "."
                   )
            )
            (if TagTotal:UseFields
                (princ "\n(Totals are live fields - rebuild the table if blocks are added or removed.)")
            )
        )

        (   t
            (princ "\n*Cancelled*")
        )
    )

    (TagTotal:Restore)
    (princ)
)

(princ)