;;; ---------------------------------------------------------------------------
;;; SumField.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Creates a LIVE field totalling the length or area of selected objects, with
;;; the option to SUBTRACT a second selection.
;;;
;;; The subtraction is what makes this more than a running total: select the
;;; outline of a room, then select the columns and voids inside it, and the
;;; field reports the net floor area. Edit any of the boundaries and the figure
;;; follows.
;;;
;;; COMMANDS
;;;   SUMLENGTH      total length, in drawing units, with subtraction prompt
;;;   SUMLENGTHMM    total length converted from millimetres to metres
;;;   SUMAREA        total area, in drawing units, with subtraction prompt
;;;   SUMAREAMM      total area converted from square millimetres to square
;;;                  metres
;;;
;;; The two converting commands exist because drawings are routinely modelled
;;; in millimetres while schedules are wanted in metres - and doing that
;;; conversion in your head, forty times, is where mistakes come from.
;;;
;;; WHERE THE FIELD CAN GO
;;; After selecting, you may pick a point for new MText, click inside a table
;;; cell to fill it, or choose Object to write into something that already
;;; exists - text, mtext, an attribute, an attributed block, or a multileader
;;; with either text or block content.
;;;
;;; Where a block or multileader carries several attributes you are asked which
;;; one. Set the tag argument in a command definition to skip that.
;;;
;;; OPEN OBJECTS STILL HAVE AN AREA. AutoCAD treats an unclosed boundary as
;;; though a straight line joined its two ends, so a boundary that was never
;;; properly closed returns the area of that implied closure rather than an
;;; error. Worth knowing before trusting a total.
;;;
;;; MAKING YOUR OWN VARIANTS
;;; Copy a command definition at the foot of this file. The three arguments are
;;; the target attribute tag (nil to be asked), whether to offer a subtraction
;;; prompt, and the field formatting code.
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; ---------------------------------------------------------------------------
;; SumField:HexToDecimal  /  SumField:EnameToID  /  SumField:ObjectID
;; ---------------------------------------------------------------------------
;; An object ID as a string, for embedding in a field expression.
;;
;; On 64-bit AutoCAD the value exceeds an AutoLISP integer. Where
;; GetObjectIdString exists it is used; on versions predating it - notably 2008
;; - the ID is recovered from the entity name's printed form and converted from
;; hexadecimal by long multiplication on the text itself.
;; ---------------------------------------------------------------------------
(defun SumField:HexToDecimal ( hex / SumField:Accumulate SumField:Carry )

    (defun SumField:Accumulate ( lst rtn )
        (if lst
            (SumField:Accumulate (cdr lst) (SumField:Carry (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )

    (defun SumField:Carry ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (SumField:Carry (/ int 10) (cdr lst)))
            )
            (SumField:Carry int '(0))
        )
    )

    (SumField:Accumulate (vl-string->list (strcase hex)) nil)
)

(defun SumField:EnameToID ( ent )
    (SumField:HexToDecimal
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

(defun SumField:ObjectID ( obj )
    (eval
        (list 'defun 'SumField:ObjectID '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (SumField:Doc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring
                          (vla-get-utility (SumField:Doc)) 'obj ':vlax-false
                    )
                   '(SumField:EnameToID (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (SumField:ObjectID obj)
)

;; Integer form of an object ID, which is what multileader attributes need.
(defun SumField:IntObjectID ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun SumField:IntObjectID ( obj ) (vla-get-objectid32 obj))
        (defun SumField:IntObjectID ( obj ) (vla-get-objectid   obj))
    )
    (SumField:IntObjectID obj)
)

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

;; ---------------------------------------------------------------------------
;; SumField:LengthProperty
;; ---------------------------------------------------------------------------
;; Returns the property name that gives an object's length.
;;
;; The name differs by type - an arc has ArcLength, a circle has Circumference
;; - and asking for the wrong one returns nothing rather than an error, so the
;; field would silently display ####.
;; ---------------------------------------------------------------------------
(defun SumField:LengthProperty ( obj )
    (cdr (assoc (vla-get-objectname obj)
               '(("AcDbArc"        . "ArcLength")
                 ("AcDbCircle"     . "Circumference")
                 ("AcDbLine"       . "Length")
                 ("AcDbPolyline"   . "Length")
                 ("AcDb2dPolyline" . "Length")
                 ("AcDb3dPolyline" . "Length")
                )
         )
    )
)

;; Every object contributes its Area under the same name.
(defun SumField:AreaProperty ( obj ) "Area")

;; ---------------------------------------------------------------------------
;; SumField:BuildTerms
;; ---------------------------------------------------------------------------
;; Prepends one term per selected object to the expression list, each preceded
;; by the given operator.
;;
;; The list is built in reverse - each term consed onto the front - so the
;; caller strips the leading operator with a single cdr rather than having to
;; find and remove a trailing one.
;;
;; sel - [pickset] the objects
;; lst - [list] expression fragments so far
;; opr - [str] " + " or " - "
;; pfn - [function] returns the property name for an object
;; ---------------------------------------------------------------------------
(defun SumField:BuildTerms ( sel lst opr pfn / idx obj )
    (repeat (setq idx (sslength sel))
        (setq idx (1- idx)
              obj (vlax-ename->vla-object (ssname sel idx))
              lst (vl-list* opr
                            "%<\\AcObjProp Object(%<\\_ObjId "
                            (SumField:ObjectID obj)
                            ">%)."
                            (apply pfn (list obj))
                            ">%"
                            lst
                  )
        )
    )
    lst
)

;; ---------------------------------------------------------------------------
;; SumField:Ssget
;; ---------------------------------------------------------------------------
(defun SumField: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)
)

;; ---------------------------------------------------------------------------
;; SumField:ListBox
;; ---------------------------------------------------------------------------
;; Single-select list returning the chosen INDEX as a one-element list, or nil.
;; The dialog name "sumfield" must match between the DCL and new_dialog.
;; ---------------------------------------------------------------------------
(defun SumField: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 "sumfield:dialog{label=\"" msg "\";spacer;"
                                ":list_box{key=\"list\";multiple_select=false;width=50;height=15;}"
                                "spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "sumfield" dch)
                )
            )
            (princ "\nThe attribute 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)) (read (strcat "(" rtn ")"))))
        )
    )
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

;; ---------------------------------------------------------------------------
;; SumField:Tables  /  SumField:HitCell
;; ---------------------------------------------------------------------------
;; Every table in the current space, and a test for whether a point falls in a
;; cell.
;;
;; HitTest needs a direction as well as a point, since a table is a planar
;; object being tested in 3D. Using the current view direction makes it hit
;; what the user can see from where they are looking.
;; ---------------------------------------------------------------------------
(defun SumField:Tables ( / sel idx result )
    (if (setq sel (ssget "_X"
                       (list '(0 . "ACAD_TABLE")
                              (if (= 1 (getvar 'cvport))
                                  (cons 410 (getvar 'ctab))
                                 '(410 . "Model")
                              )
                       )
                  )
        )
        (repeat (setq idx (sslength sel))
            (setq result (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) result))
        )
    )
    result
)

(defun SumField:HitCell ( tables pnt / dir )
    (setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
          pnt (vlax-3D-point pnt)
    )
    (vl-some
        (function
            (lambda ( tab / row col )
                (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
                    (list tab row col)
                )
            )
        )
        tables
    )
)

;; ---------------------------------------------------------------------------
;; SumField:MleaderAttributes
;; ---------------------------------------------------------------------------
;; Returns ((tagName . objectId) ...) for a multileader's block content.
;;
;; A multileader's attributes are not objects that can be written to directly -
;; a value is set by naming the attribute DEFINITION's id inside the block, so
;; those ids have to be collected from the block definition.
;; ---------------------------------------------------------------------------
(defun SumField:MleaderAttributes ( mld / rtn )
    (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld))
                            (vla-get-contentblockname mld))
        (if (and (= "AcDbAttributeDefinition" (vla-get-objectname obj))
                 (= :vlax-false (vla-get-constant obj))
            )
            (setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (SumField:IntObjectID obj)) rtn))
        )
    )
    (reverse rtn)
)

;; Writes text, clearing first - writing a field expression over an existing
;; one without clearing can leave the old field's evaluated remains behind.
(defun SumField:PutText ( obj str )
    (vla-put-textstring obj "")
    (vla-put-textstring obj str)
    t
)

;; Forces a field to evaluate; without it the raw expression shows until regen.
(defun SumField:UpdateField ( ent / cmd rtn )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (setq rtn (vl-cmdf "_.updatefield" ent ""))
    (setvar 'cmdecho cmd)
    rtn
)

;; ---------------------------------------------------------------------------
;; SumField:Output
;; ---------------------------------------------------------------------------
;; Places the field expression, offering the point, table cell and existing
;; object routes.
;;
;; The loop continues until something is successfully written or the user
;; exits. Point and Object switch between the two prompt modes, which is why
;; the flag is toggled rather than the loop restarted.
;;
;; tag - [str] preset attribute tag, or nil to be asked
;; str - [str] the field expression
;; ---------------------------------------------------------------------------
(defun SumField:Output ( tag str / ent enx flg idx obj oid sel tab tmp typ )

    (setq tab (SumField:Tables))

    (while
        (not
            (progn
                (if flg
                    (progn
                        (setvar 'errno 0)
                        (initget "Point eXit")
                        (setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block [Point/eXit] <eXit>: "))
                    )
                    (progn
                        (initget "Object eXit")
                        (setq sel (getpoint "\nSpecify point or table cell [Object/eXit] <eXit>: "))
                    )
                )
                (cond
                    (   (= 7 (getvar 'errno))
                        (princ "\nMissed, try again.")
                    )

                    (   (or (null sel) (= "eXit" sel)))

                    (   (= "Point" sel)  (setq flg nil))
                    (   (= "Object" sel) (not (setq flg t)))

                    ;; -------------------------------------------------------
                    ;; Object mode.
                    ;; -------------------------------------------------------
                    (   flg
                        (setq ent (car sel)
                              enx (entget ent)
                              typ (cdr (assoc 0 enx))
                              obj (vlax-ename->vla-object ent)
                        )
                        (cond
                            ;; Plain text or mtext, picked at the top level.
                            (   (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
                                (if (vlax-write-enabled-p obj)
                                    (SumField:PutText obj str)
                                    (princ "\nThat text object is on a locked layer.")
                                )
                            )

                            ;; An attribute picked directly, with no preset tag.
                            (   (and (= "ATTRIB" typ) (/= 'str (type tag)))
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (SumField:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (SumField:UpdateField ent)
                                        )
                                    )
                                    (princ "\nThat attribute is on a locked layer.")
                                )
                            )

                            ;; An attributed block - resolve which attribute.
                            (   (and
                                    (or (and (= "ATTRIB" typ) (setq tmp (cdr (assoc 330 enx))))
                                        (and (setq tmp (last (cadddr sel)))
                                             (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                        )
                                    )
                                    (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                    (or (and (= 'str (type tag))
                                             (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                             (setq obj (nth idx tmp))
                                        )
                                        (and (not (cdr tmp)) (setq obj (car tmp)))
                                        (and (setq idx (SumField:ListBox "Choose Attribute"
                                                           (mapcar 'vla-get-tagstring tmp)))
                                             (setq obj (nth (car idx) tmp))
                                        )
                                    )
                                )
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (SumField:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (SumField:UpdateField (vlax-vla-object->ename obj))
                                        )
                                    )
                                    (princ "\nThat attribute is on a locked layer.")
                                )
                            )

                            ;; A multileader - content may be text or a block.
                            (   (and (= 2 (length sel)) (= "MULTILEADER" typ))
                                (setq typ (cdr (assoc 172 (reverse enx))))
                                (cond
                                    (   (and (<= acblockcontent typ acmtextcontent)
                                             (not (vlax-write-enabled-p obj))
                                        )
                                        (princ "\nThat multileader is on a locked layer.")
                                    )
                                    (   (= acmtextcontent typ)
                                        (SumField:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (vla-regen (SumField:Doc) acactiveviewport)
                                        )
                                        t
                                    )
                                    (   (and (= acblockcontent typ)
                                             (setq tmp (SumField:MleaderAttributes obj))
                                             (or (and (= 'str (type tag))
                                                      (setq oid (cdr (assoc (strcase tag) tmp)))
                                                 )
                                                 (and (not (cdr tmp)) (setq oid (cdar tmp)))
                                                 (and (setq idx (SumField:ListBox "Choose Attribute" (mapcar 'car tmp)))
                                                      (setq oid (cdr (nth (car idx) tmp)))
                                                 )
                                             )
                                        )
                                        (SumField:SetMleaderAttribute obj oid str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (vla-regen (SumField:Doc) acactiveviewport)
                                        )
                                        t
                                    )
                                    (   (princ "\nThat multileader has no editable content."))
                                )
                            )

                            (   (princ "\nThat is not text, mtext, a multileader, an attribute or an attributed block."))
                        )
                    )

                    ;; -------------------------------------------------------
                    ;; Point mode: a table cell if the point lands in one,
                    ;; otherwise new MText.
                    ;; -------------------------------------------------------
                    (   (setq tmp (SumField:HitCell tab (trans sel 1 0)))
                        (if (vlax-write-enabled-p (car tmp))
                            (not (vl-catch-all-error-p
                                     (vl-catch-all-apply 'vla-settext (append tmp (list str)))
                                 )
                            )
                            (princ "\nThat table is on a locked layer.")
                        )
                    )

                    (   (vla-addmtext
                            (vlax-get-property (SumField:Doc)
                                (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                            )
                            (vlax-3D-point (trans sel 1 0))
                            0.0
                            str
                        )
                    )
                )
            )
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; SumField:Run
;; ---------------------------------------------------------------------------
;; Shared implementation for all four commands.
;;
;; ftr - [list] ssget filter for the selectable objects
;; pfn - [function] returns the property name for an object
;; tag - [str] preset attribute tag, or nil
;; sub - [boolean] offer a subtraction prompt
;; fmt - [str] field formatting code, or nil
;; msg - [str] what is being totalled, for the prompts
;; ---------------------------------------------------------------------------
(defun SumField:Run ( ftr pfn tag sub fmt msg / *error* vars vals lst ss1 ss2 )

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

    (defun SumField: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 )
        (SumField:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** SUMFIELD error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; 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")

    (if (setq ss1 (SumField:Ssget (strcat "\nSelect objects to total " msg " <exit>: ") ftr))
        (progn
            ;; Subtractions are built FIRST so they end up at the tail of the
            ;; expression, after the additions - which is both readable and the
            ;; order the arithmetic needs.
            (if sub
                (if (setq ss2 (SumField:Ssget "\nSelect objects to subtract <skip>: " ftr))
                    (setq lst (SumField:BuildTerms ss2 lst " - " pfn))
                )
            )

            ;; The cdr strips the leading operator from the first term.
            (setq lst (cdr (SumField:BuildTerms ss1 lst " + " pfn)))

            ;; A single object needs no arithmetic wrapper; more than one does.
            ;; Six fragments is one term, so anything longer is a sum.
            (if (< 5 (length lst))
                (setq lst (append '("%<\\AcExpr ") lst '(">%")))
            )

            ;; Formatting is spliced in before the closing marker.
            (if (and fmt (/= "" fmt))
                (setq lst (reverse (vl-list* "\">%" fmt " \\f \"" (cdr (reverse lst)))))
            )

            (SumField:Output tag (apply 'strcat lst))
            (princ (strcat "\nField created from " (itoa (sslength ss1)) " object"
                           (if (= 1 (sslength ss1)) "" "s")
                           (if ss2 (strcat ", less " (itoa (sslength ss2))) "")
                           "."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (SumField:Restore)
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; SELECTION FILTERS
;;;
;;; Both exclude 3D polylines and meshes. The mask differs because the area
;;; filter must also reject the closed-polygon flag combinations that have no
;;; single planar area.
;;; ---------------------------------------------------------------------------

(setq SumField:LengthFilter
    (list
        (list '(000 . "ARC,CIRCLE,LINE,*POLYLINE")
              '(-04 . "<NOT")
                  '(-04 . "<AND") '(000 . "POLYLINE") '(-04 . "&") '(070 . 80) '(-04 . "AND>")
              '(-04 . "NOT>")
               (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model"))
        )
    )
)

(setq SumField:AreaFilter
    (list
        (list '(000 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE,REGION,SPLINE")
              '(-04 . "<NOT")
                  '(-04 . "<AND") '(000 . "POLYLINE") '(-04 . "&") '(070 . 88) '(-04 . "AND>")
              '(-04 . "NOT>")
               (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model"))
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; COMMANDS
;;;
;;; Copy any line and edit the three arguments to make your own variant.
;;; Formatting codes: %lu6 is decimal units, %qf1 suppresses trailing zeros,
;;; %ct8[n] multiplies by n.
;;;
;;; The original named these LF, LFM, AF and AFM. Renamed to say what they do -
;;; and because AF collided with a command of the same name in the area
;;; labelling routine.
;;; ---------------------------------------------------------------------------

;; Total length, drawing units, with a subtraction prompt.
(defun c:SUMLENGTH nil
    (SumField:Run SumField:LengthFilter 'SumField:LengthProperty nil t "%lu6" "length")
)

;; Total length converted from millimetres to metres, no subtraction prompt.
(defun c:SUMLENGTHMM nil
    (SumField:Run SumField:LengthFilter 'SumField:LengthProperty nil nil "%lu6%ct8[0.001]" "length")
)

;; Total area, drawing units, with a subtraction prompt.
(defun c:SUMAREA nil
    (SumField:Run SumField:AreaFilter 'SumField:AreaProperty nil t "%lu6%qf1" "area")
)

;; Total area converted from square millimetres to square metres.
(defun c:SUMAREAMM nil
    (SumField:Run SumField:AreaFilter 'SumField:AreaProperty nil nil "%lu6%qf1%ct8[1e-6]" "area")
)

(princ)