;;; ---------------------------------------------------------------------------
;;; AreaSumField.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Creates a LIVE field showing the combined area of several selected objects.
;;;
;;; Select any number of closed objects, pick a point, and an MText field is
;;; created there displaying their total area. Because it is a field and not a
;;; typed number, it updates itself whenever the geometry changes - stretch one
;;; of the boundaries and the figure follows.
;;;
;;; PICK INSIDE A TABLE CELL AND IT FILLS THE CELL
;;; If the point you pick falls inside an AutoCAD table cell, the field goes
;;; into that cell instead of being created as loose MText. That makes this
;;; directly usable for building an areas schedule.
;;;
;;; WHAT GETS BUILT
;;; For a single object, the field is a straightforward object-property
;;; reference to its Area.
;;;
;;; For several, an arithmetic expression field is built that adds the areas
;;; together - literally "areaOfA + areaOfB + areaOfC" expressed in field
;;; syntax. The whole sum is then formatted once, at the end.
;;;
;;; THE FORMATTING CODE
;;; AreaSumField:Format below controls how the number is displayed:
;;;
;;;     %lu6    linear units in decimal format
;;;     %qf1    suppress trailing zeros
;;;
;;; Edit it to suit your output. For example "%lu6%pr2" would force two decimal
;;; places instead. Running FIELDCODE on an existing field you like the look of
;;; is the quickest way to discover the code you want.
;;;
;;;   AREASUM  - create a live field totalling the area of selected objects
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Field formatting code - see the note in the header.
(setq AreaSumField:Format "%lu6%qf1")

;; ---------------------------------------------------------------------------
;; AreaSumField:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string, for embedding in a field expression.
;;
;; This has to cope with both 32-bit and 64-bit AutoCAD. On 64-bit the ID
;; exceeds what an AutoLISP integer can hold, so it must be fetched as a string
;; through GetObjectIdString; on 32-bit the plain ObjectID property is fine.
;;
;; The definition rewrites ITSELF on first call - the eval/defun builds whichever
;; version this machine needs and installs it under the same name, so the
;; architecture test runs once per session rather than once per object. On a
;; selection of several hundred boundaries that is a worthwhile saving.
;; ---------------------------------------------------------------------------
(defun AreaSumField:ObjectID ( obj )
    (eval
        (list 'defun 'AreaSumField:ObjectID '( obj )
            (if (and (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                     (vlax-method-applicable-p
                         (vla-get-utility (AreaSumField:Doc)) 'getobjectidstring
                     )
                )
                (list 'vla-getobjectidstring
                      (vla-get-utility (AreaSumField:Doc))
                      'obj
                      ':vlax-false
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (AreaSumField:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; AreaSumField:Doc
;; ---------------------------------------------------------------------------
;; Returns the active document object, caching it by the same self-rewriting
;; trick so the COM lookup happens only once per session.
;; ---------------------------------------------------------------------------
(defun AreaSumField:Doc nil
    (eval (list 'defun 'AreaSumField:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (AreaSumField:Doc)
)

;; ---------------------------------------------------------------------------
;; AreaSumField:Tables
;; ---------------------------------------------------------------------------
;; Returns every table object in the space the user is working in, as a list of
;; VLA-objects. Used to test whether the picked point landed in a cell.
;; ---------------------------------------------------------------------------
(defun AreaSumField: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
)

;; ---------------------------------------------------------------------------
;; AreaSumField:HitCell
;; ---------------------------------------------------------------------------
;; If pnt falls inside one of the supplied tables, returns (table row column);
;; otherwise nil.
;;
;; HitTest needs a direction as well as a point, because a table is a planar
;; object being tested in 3D space. The current view direction is used, which
;; is what makes the test behave as the user expects - it hits what they can
;; see from where they are looking.
;; ---------------------------------------------------------------------------
(defun AreaSumField: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
    )
)

;; ---------------------------------------------------------------------------
;; AreaSumField:Build
;; ---------------------------------------------------------------------------
;; Returns the field expression string for the selected objects.
;;
;; One object gets a direct property reference. Several get an AcExpr
;; arithmetic field summing the individual areas.
;;
;; In the multiple case the pieces are accumulated with a " + " separator after
;; each, which leaves one trailing separator on the end; the reverse/cdr/reverse
;; dance strips that final " + " off before the expression is assembled.
;; ---------------------------------------------------------------------------
(defun AreaSumField:Build ( sel / idx parts )
    (if (= 1 (sslength sel))
        (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                (AreaSumField:ObjectID (vlax-ename->vla-object (ssname sel 0)))
                ">%).Area \\f \"" AreaSumField:Format "\">%"
        )
        (progn
            (repeat (setq idx (sslength sel))
                (setq parts
                    (vl-list*
                        "%<\\AcObjProp Object(%<\\_ObjId "
                        (AreaSumField:ObjectID
                            (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                        )
                        ">%).Area>%" " + "
                        parts
                    )
                )
            )
            (strcat "%<\\AcExpr "
                    (apply 'strcat (reverse (cdr (reverse parts))))
                    " \\f \"" AreaSumField:Format "\">%"
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:AREASUM  -  main routine
;; ---------------------------------------------------------------------------
;; Note that idx, tab and tmp were all left undeclared in the original, and so
;; leaked into the global namespace on every run. Everything is properly
;; localised here.
;; ---------------------------------------------------------------------------
(defun c:AREASUM ( / *error* vars vals sel ins cell text )

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

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

    (setvar "CMDECHO" 0)

    (if (and (setq sel (ssget '((0 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE,REGION,SPLINE"))))
             (setq ins (getpoint "\nPick point or table cell for the field: "))
        )
        (progn
            (setq text (AreaSumField:Build sel))
            ;; 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 cell (AreaSumField:HitCell (AreaSumField:Tables) (trans ins 1 0)))
                (progn
                    ;; cell is (table row col); appending the text gives the
                    ;; four arguments vla-settext expects.
                    (apply 'vla-settext (append cell (list text)))
                    (princ "\nArea field written into the table cell.")
                )
                (progn
                    (vla-addmtext
                        (vlax-get-property (AreaSumField:Doc)
                            (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                        )
                        (vlax-3D-point (trans ins 1 0))
                        0.0
                        text
                    )
                    (princ (strcat "\nArea field created for "
                                   (itoa (sslength sel))
                                   " object" (if (= 1 (sslength sel)) "" "s") "."
                           )
                    )
                )
            )
        )
        (princ "\n*Cancelled*")
    )

    (AreaSumField:Restore)
    (princ)
)

(princ)