;;; ---------------------------------------------------------------------------
;;; AreaToTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Pushes an area - or the sum of several areas - into a block ATTRIBUTE as a
;;; live field.
;;;
;;; Select the boundaries, then pick the attribute (or the block containing it),
;;; and the attribute is populated with a field showing the total area. Because
;;; it is a field, editing the boundary updates the attribute automatically.
;;;
;;; This is how you make a room tag that always tells the truth: the room name
;;; is typed, the area is a field, and stretching the room wall updates the tag
;;; without anyone remembering to.
;;;
;;; HOW THE TARGET IS CHOSEN
;;; You may pick either the attribute itself, or anywhere on the block that
;;; contains it. If the block holds exactly one attribute, that one is used
;;; without further prompting. If it holds several, a list is shown to choose
;;; from.
;;;
;;; PRESETTING A TAG
;;; Set AreaToTag:Tag below to an attribute tag name - for example "AREA" - and
;;; that attribute will be used automatically whenever the picked block has one,
;;; skipping the selection list entirely. Leave it nil to always be asked.
;;;
;;; THE FORMATTING CODE
;;; AreaToTag:Format controls the number display:
;;;     %lu6  decimal linear units
;;;     %qf1  suppress trailing zeros
;;; Run FIELDSNOOP on a field you like to discover its code.
;;;
;;;   AREATOTAG  - write an area field into an attribute
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; Optional preset attribute tag; nil means always ask. See the header.
(setq AreaToTag:Tag nil)

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

;; ---------------------------------------------------------------------------
;; AreaToTag:HexToDecimal
;; ---------------------------------------------------------------------------
;; Converts a hexadecimal string to decimal, as a string.
;;
;; Needed because a 64-bit object ID is too large for an AutoLISP integer, so
;; the conversion must be done on the text itself. The helpers perform long
;; multiplication by 16 through a list of decimal digits held least-significant
;; first.
;; ---------------------------------------------------------------------------
(defun AreaToTag:HexToDecimal ( hex / AreaToTag:Accumulate AreaToTag:Carry )

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

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

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

;; ---------------------------------------------------------------------------
;; AreaToTag:EnameToID
;; ---------------------------------------------------------------------------
;; Derives an object ID from an entity name's printed form - the fallback for
;; 64-bit AutoCAD versions predating GetObjectIdString, notably 2008.
;; ---------------------------------------------------------------------------
(defun AreaToTag:EnameToID ( ent )
    (AreaToTag:HexToDecimal
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; ---------------------------------------------------------------------------
;; AreaToTag:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string, using whichever method this AutoCAD
;; supports. The test runs once, then this function replaces itself.
;; ---------------------------------------------------------------------------
(defun AreaToTag:ObjectID ( obj )
    (eval
        (list 'defun 'AreaToTag:ObjectID '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (AreaToTag:Doc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring
                          (vla-get-utility (AreaToTag:Doc)) 'obj ':vlax-false
                    )
                   '(AreaToTag:EnameToID (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (AreaToTag:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; AreaToTag:ListBox
;; ---------------------------------------------------------------------------
;; Single-select list, returning the chosen INDEX as a one-element list, or nil.
;;
;; The dialog is written out at run time and deleted immediately after, so this
;; file stays self-contained with no companion .dcl to deploy. The dialog name
;; "areatotag" must match between the DCL text and the new_dialog call.
;; ---------------------------------------------------------------------------
(defun AreaToTag: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 "areatotag: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 "areatotag" 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
)

;; ---------------------------------------------------------------------------
;; AreaToTag:Build
;; ---------------------------------------------------------------------------
;; Returns the field expression for the selected objects.
;;
;; A single object gets a direct property reference; several get an AcExpr
;; arithmetic field summing their areas. In the multiple case each piece is
;; followed by " + ", leaving one trailing separator that the reverse/cdr/
;; reverse strips before assembly.
;; ---------------------------------------------------------------------------
(defun AreaToTag:Build ( sel / idx parts )
    (if (= 1 (sslength sel))
        (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                (AreaToTag:ObjectID (vlax-ename->vla-object (ssname sel 0)))
                ">%).Area \\f \"" AreaToTag:Format "\">%"
        )
        (progn
            (repeat (setq idx (sslength sel))
                (setq parts
                    (vl-list*
                        "%<\\AcObjProp Object(%<\\_ObjId "
                        (AreaToTag:ObjectID
                            (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                        )
                        ">%).Area>%" " + "
                        parts
                    )
                )
            )
            (strcat "%<\\AcExpr "
                    (apply 'strcat (reverse (cdr (reverse parts))))
                    " \\f \"" AreaToTag:Format "\">%"
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:AREATOTAG  -  main routine
;; ---------------------------------------------------------------------------
(defun c:AREATOTAG ( / *error* vars vals sel pick enx att owner atts idx )

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

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

    (setvar "CMDECHO" 0)

    (if (and
            (setq sel (ssget '((0 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE,REGION,SPLINE"))))
            (progn
                ;; Re-prompt until a usable attribute is identified.
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq pick (nentsel "\nSelect attribute or attributed block: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null pick) nil)

                            ;; Case 1: an attribute was picked directly, and no
                            ;; preset tag is forcing a particular one.
                            (   (and (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (car pick))))))
                                     (/= 'str (type AreaToTag:Tag))
                                )
                                (setq att (vlax-ename->vla-object (car pick)))
                                nil
                            )

                            ;; Case 2: work out the owning block reference -
                            ;; either from the picked attribute's owner (DXF
                            ;; 330), or from the nesting chain nentsel returns -
                            ;; then fetch its attributes.
                            (   (and
                                    (or (and (= "ATTRIB" (cdr (assoc 0 enx)))
                                             (setq owner (cdr (assoc 330 enx)))
                                        )
                                        (and (setq owner (last (cadddr pick)))
                                             (= "INSERT" (cdr (assoc 0 (entget owner))))
                                        )
                                    )
                                    (setq atts (vlax-invoke (vlax-ename->vla-object owner) 'getattributes))
                                )
                                (not
                                    (or
                                        ;; Preset tag, if it exists on this block.
                                        (and (= 'str (type AreaToTag:Tag))
                                             (setq idx (vl-position (strcase AreaToTag:Tag)
                                                                    (mapcar 'vla-get-tagstring atts)))
                                             (setq att (nth idx atts))
                                        )
                                        ;; Exactly one attribute - no need to ask.
                                        (and (not (cdr atts))
                                             (setq att (car atts))
                                        )
                                        ;; Otherwise offer the list.
                                        (and (setq idx (AreaToTag:ListBox "Choose Attribute"
                                                           (mapcar 'vla-get-tagstring atts)))
                                             (setq att (nth (car idx) atts))
                                        )
                                    )
                                )
                            )

                            (   (princ "\nThat is not an attribute or an attributed block."))
                        )
                    )
                )
                (= 'vla-object (type att))
            )
        )
        (progn
            ;; 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")
            (vla-put-textstring att (AreaToTag:Build sel))

            ;; The field must be told to evaluate, or the attribute displays
            ;; the raw expression until the next regen.
            (vl-cmdf "_.updatefield" (vlax-vla-object->ename att) "")

            (princ (strcat "\nArea field written into attribute \""
                           (vla-get-tagstring att) "\" from "
                           (itoa (sslength sel)) " object"
                           (if (= 1 (sslength sel)) "" "s") "."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (AreaToTag:Restore)
    (princ)
)

(princ)