;;; ---------------------------------------------------------------------------
;;; FieldStamp.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; A toolkit for building your own one-key field commands.
;;;
;;; Inserting a field through the FIELD dialog takes half a dozen clicks. When
;;; you need forty of them, all referencing the same property, that becomes a
;;; genuine waste of an afternoon. This lets you define a single command that
;;; does the whole thing in two picks.
;;;
;;; READY-MADE COMMANDS
;;;   AREASTAMP    - pick an object, pick a point, get text showing its area
;;;   LENGTHSTAMP  - the same for length, as MText, with a "Length:" prefix and
;;;                  a 0.1 conversion factor applied
;;;   STYLESTAMP   - reads a style name into an EXISTING text object
;;;
;;; These are examples as much as tools; the point is to copy the pattern at
;;; the foot of this file and make your own.
;;;
;;; BUILDING YOUR OWN
;;; Add one line per command:
;;;
;;;     (defun c:MYSTAMP nil (FieldStamp:Insert "Area" "%lu6%qf1" 2))
;;;
;;; The three arguments are:
;;;
;;;   PROPERTY  the object property the field reads, e.g. "Area", "Length",
;;;             "Radius", "Layer", "StyleName".
;;;
;;;   FORMAT    the field formatting code, or "" for none.
;;;                 %lu6              decimal units
;;;                 %pr3              three decimal places
;;;                 %ps[Length:,]     prefix the value with "Length:"
;;;                 %ct8[0.1]         multiply by 0.1 (mm to cm, say)
;;;                 %tc1              force upper case
;;;
;;;   MODE      1 = write into an EXISTING text, mtext or attribute
;;;             2 = create a new TEXT object at a picked point
;;;             3 = create a new MTEXT object at a picked point
;;;
;;; THE EASY WAY TO FIND THE ARGUMENTS
;;; Build the field once through the normal FIELD dialog until it displays
;;; exactly right. The dialog shows the finished expression along the bottom:
;;;
;;;     %<\AcObjProp Object(%<\_ObjId 2129673136>%).Area \f "%lu6%qf1">%
;;;                                               ^^^^      ^^^^^^^^^
;;;                                             property     format
;;;
;;; Read the two values straight out of it. FIELDSNOOP in this library will
;;; also report the formatting code of any existing field.
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; ---------------------------------------------------------------------------
;; FieldStamp:SelectWithProperty
;; ---------------------------------------------------------------------------
;; Prompts until the user picks an object that actually exposes the named
;; property, or gives up.
;;
;; Testing for the property rather than for an entity TYPE is what keeps this
;; general: any object exposing "Area" can be used by an area command, without
;; the routine needing to know which types those are.
;;
;; prop - [str] property name
;; func - [sym] entsel or nentsel
;; ---------------------------------------------------------------------------
(defun FieldStamp:SelectWithProperty ( prop func / ent )
    (while
        (progn
            (setvar 'errno 0)
            (setq ent (car (func (strcat "\nSelect object with " prop " property: "))))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (null ent) nil)
                (   (not (vlax-property-available-p (vlax-ename->vla-object ent) prop))
                    (princ (strcat "\nThat object has no " prop " property - try again."))
                )
            )
        )
    )
    ent
)

;; ---------------------------------------------------------------------------
;; FieldStamp:Expression
;; ---------------------------------------------------------------------------
;; Prompts for the source object and returns the complete field expression
;; referencing the requested property, or nil if cancelled.
;;
;; This function DEFINES ITSELF on first use. The reason is the object ID: on
;; 64-bit AutoCAD it must be fetched as a string through GetObjectIdString,
;; while older versions use the plain ObjectID property. Rather than testing
;; that on every call, the test is performed once and the appropriate version
;; installed under this name.
;; ---------------------------------------------------------------------------
(   (lambda nil
        (eval
            (list 'defun 'FieldStamp:Expression '( prop format / ent )
                (list 'if '(setq ent (FieldStamp:SelectWithProperty prop entsel))
                    (list 'strcat "%<\\AcObjProp Object(%<\\_ObjId "
                        (if (vlax-method-applicable-p
                                (vla-get-utility (FieldStamp:Doc)) 'getobjectidstring
                            )
                            (list 'vla-getobjectidstring
                                  (vla-get-utility (FieldStamp:Doc))
                                 '(vlax-ename->vla-object ent)
                                 ':vlax-false
                            )
                           '(itoa (vla-get-objectid (vlax-ename->vla-object ent)))
                        )
                        ">%)." 'prop
                        ;; Formatting is only appended when there is some.
                       '(if (/= "" format) (strcat " \\f \"" format "\">%") ">%")
                    )
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; FieldStamp:Insert
;; ---------------------------------------------------------------------------
;; The workhorse. Prompts for the source object, builds the field, and places
;; it according to the mode.
;;
;; prop   - [str] property to reference
;; format - [str] field formatting code, or ""
;; mode   - [int] 1 existing object, 2 new text, 3 new mtext
;; ---------------------------------------------------------------------------
(defun FieldStamp:Insert ( prop format mode / *error* vars vals ent ins obj str space )

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

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

    (setvar "CMDECHO" 0)

    (if (setq str (FieldStamp:Expression prop format))
        (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")
            (setq space
                (vlax-get-property (FieldStamp:Doc)
                    (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                )
            )

            (cond
                ;; -----------------------------------------------------------
                ;; Mode 1 - write into an existing annotation object. nentsel
                ;; is used so an attribute inside a block can be picked.
                ;; -----------------------------------------------------------
                (   (= 1 mode)
                    (if (setq ent (FieldStamp:SelectWithProperty "Textstring" nentsel))
                        (progn
                            (setq obj (vlax-ename->vla-object ent))
                            ;; Cleared first: writing a new field expression
                            ;; over an existing one without clearing can leave
                            ;; the previous field's evaluated remains behind.
                            (vla-put-textstring obj "")
                            (vla-put-textstring obj str)
                            ;; Attributes need an explicit nudge, or they show
                            ;; the raw expression until the next regen.
                            (if (= "ATTRIB" (cdr (assoc 0 (entget ent))))
                                (vl-cmdf "_.updatefield" ent "")
                            )
                            (princ "\nField written into the selected object.")
                        )
                        (princ "\n*Cancelled*")
                    )
                )

                ;; -----------------------------------------------------------
                ;; Mode 2 - new TEXT at the current text height.
                ;; -----------------------------------------------------------
                (   (= 2 mode)
                    (if (setq ins (getpoint "\nSpecify point for text: "))
                        (progn
                            (vla-addtext space str
                                (vlax-3D-point (trans ins 1 0))
                                (getvar 'textsize)
                            )
                            (princ "\nField text created.")
                        )
                        (princ "\n*Cancelled*")
                    )
                )

                ;; -----------------------------------------------------------
                ;; Mode 3 - new MTEXT. The 0.0 width means unbounded, so the
                ;; text does not wrap.
                ;; -----------------------------------------------------------
                (   (= 3 mode)
                    (if (setq ins (getpoint "\nSpecify point for mtext: "))
                        (progn
                            (vla-addmtext space
                                (vlax-3D-point (trans ins 1 0))
                                0.0 str
                            )
                            (princ "\nField mtext created.")
                        )
                        (princ "\n*Cancelled*")
                    )
                )

                (   t
                    (princ (strcat "\nUnknown mode " (itoa mode) " - use 1, 2 or 3."))
                )
            )
        )
        (princ "\n*Cancelled* - no source object selected.")
    )

    (FieldStamp:Restore)
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; READY-MADE COMMANDS
;;;
;;; Copy any of these lines and edit the three arguments to make your own.
;;; The originals were named test1, test2 and test3 - renamed here to say what
;;; they actually do.
;;; ---------------------------------------------------------------------------

;; Area, as TEXT, in the drawing's current units and precision.
(defun c:AREASTAMP nil
    (FieldStamp:Insert "Area" "%lu6%qf1" 2)
)

;; Length, as MTEXT, to three decimal places, prefixed "Length:" and converted
;; by a factor of 0.1.
(defun c:LENGTHSTAMP nil
    (FieldStamp:Insert "Length" "%lu2%pr3%ps[Length:,]%ct8[0.1]" 3)
)

;; Style name, written into an EXISTING text object, forced to upper case.
(defun c:STYLESTAMP nil
    (FieldStamp:Insert "StyleName" "%tc1" 1)
)

(princ)