;;; ---------------------------------------------------------------------------
;;; FieldSnoop.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Reveals the FORMATTING CODE behind a field, so it can be reused elsewhere.
;;;
;;; Field formatting codes are short, cryptic and almost impossible to work out
;;; from the dialogs - things like "%lu6%qf1" or "%lu2%pr3%ps[,m2]". When you
;;; have a field somewhere in the drawing that displays exactly the way you
;;; want, this tells you the code that makes it do so, ready to paste into your
;;; own routines or into another field.
;;;
;;; Works on Text, MText, attributes, multileaders and dimensions.
;;;
;;; WHY EXTRACTING A FIELD IS NOT SIMPLE
;;; A field is not stored in the text object you can see. The object holds a
;;; placeholder, and the real expression lives in an ACAD_FIELD dictionary
;;; hanging off it. Worse, the expression can reference OTHER fields, which
;;; live in their own dictionaries, and any expression longer than 250
;;; characters is split across multiple DXF group 3 entries that must be
;;; stitched back together.
;;;
;;; So reconstructing the text of a field means: read the placeholder, walk
;;; into the dictionary, reassemble the split string, then recursively resolve
;;; every nested field and object reference it contains. That is what the three
;;; helper functions below do between them.
;;;
;;;   FIELDSNOOP  - report the formatting code of a selected field
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; FieldSnoop:Doc  -  cached active document
;; ---------------------------------------------------------------------------
;; Rewrites itself on first call so the COM lookup happens once per session.
;; ---------------------------------------------------------------------------
(defun FieldSnoop:Doc nil
    (eval (list 'defun 'FieldSnoop:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (FieldSnoop:Doc)
)

;; ---------------------------------------------------------------------------
;; FieldSnoop:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string. On 64-bit AutoCAD the value is too large
;; for an AutoLISP integer and must be fetched via GetObjectIdString; on 32-bit
;; the plain property is fine. The architecture test is performed once, then
;; this function replaces itself with whichever version applies.
;; ---------------------------------------------------------------------------
(defun FieldSnoop:ObjectID ( obj )
    (eval
        (list 'defun 'FieldSnoop:ObjectID '( obj )
            (if (and (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                     (vlax-method-applicable-p
                         (vla-get-utility (FieldSnoop:Doc)) 'getobjectidstring
                     )
                )
                (list 'vla-getobjectidstring
                      (vla-get-utility (FieldSnoop:Doc)) 'obj ':vlax-false
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (FieldSnoop:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; FieldSnoop:Code
;; ---------------------------------------------------------------------------
;; Returns the full text of the field expression held by an entity, or nil if
;; the entity carries no field.
;;
;; Three nested helpers do the work:
;;
;;   FieldSnoop:Assemble  - rebuilds the expression string from its DXF group 3 fragments.
;;               AutoCAD splits any string over 250 characters across repeated
;;               group 3 entries, with the final remainder in group 2, so all
;;               of them have to be concatenated in order.
;;
;;   FieldSnoop:SwapObjs  - field expressions reference objects by an internal index
;;               ("ObjIdx"), which is meaningless outside the file. Each one is
;;               replaced with the real object ID taken from the accompanying
;;               DXF 331 entries.
;;
;;   FieldSnoop:SwapFlds  - a field may embed other fields, flagged "\_FldIdx" and stored
;;               in their own dictionaries via DXF 360. Each is resolved by
;;               recursing into that dictionary and splicing its text in.
;;
;; Both swap helpers walk the entity data forward as they go - the (cdr (member
;; ent enx)) argument - so that repeated references consume successive DXF
;; entries rather than all resolving to the first one.
;; ---------------------------------------------------------------------------
(defun FieldSnoop:Code ( ent / FieldSnoop:SwapFlds FieldSnoop:SwapObjs FieldSnoop:Assemble enx )

    (defun FieldSnoop:Assemble ( enx / itm )
        (if (setq itm (assoc 3 enx))
            (strcat (cdr itm) (FieldSnoop:Assemble (cdr (member itm enx))))
            (cond ((cdr (assoc 2 enx))) (""))
        )
    )

    (defun FieldSnoop:SwapObjs ( str enx / ent pos )
        (if (setq pos (vl-string-search "ObjIdx" str))
            (strcat
                (substr str 1 (+ pos 5)) " "
                (FieldSnoop:ObjectID
                    (vlax-ename->vla-object (cdr (setq ent (assoc 331 enx))))
                )
                (FieldSnoop:SwapObjs (substr str (1+ (vl-string-search ">%" str pos)))
                          (cdr (member ent enx))
                )
            )
            str
        )
    )

    (defun FieldSnoop:SwapFlds ( str enx / ent fld pos )
        (if (setq pos (vl-string-search "\\_FldIdx" (setq str (FieldSnoop:SwapObjs str enx))))
            (progn
                (setq ent (assoc 360 enx)
                      fld (entget (cdr ent))
                )
                (strcat
                    (substr str 1 pos)
                    (FieldSnoop:SwapFlds (FieldSnoop:Assemble fld) fld)
                    (FieldSnoop:SwapFlds (substr str (1+ (vl-string-search ">%" str pos)))
                              (cdr (member ent enx))
                    )
                )
            )
            str
        )
    )

    ;; Walk from the entity into its field dictionary. Any step returning nil
    ;; means the object simply has no field attached.
    (if (and (wcmatch (cdr (assoc 0 (setq enx (entget ent))))
                      "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION")
             (setq enx (cdr (assoc 360 enx)))
             (setq enx (dictsearch enx "ACAD_FIELD"))
             (setq enx (dictsearch (cdr (assoc -1 enx)) "TEXT"))
        )
        (FieldSnoop:SwapFlds (FieldSnoop:Assemble enx) enx)
    )
)

;; ---------------------------------------------------------------------------
;; FieldSnoop:Formatting
;; ---------------------------------------------------------------------------
;; Returns every formatting code found in a field expression, in order.
;;
;; Formatting is introduced by the marker \f " and terminated by ">%, so the
;; codes are simply the substrings lying between those two delimiters. The
;; function recurses through the remainder of the expression to pick up any
;; further codes belonging to nested fields.
;;
;; The caller takes the LAST of the list, which is the outermost - the one that
;; governs how the finished value is actually displayed.
;; ---------------------------------------------------------------------------
(defun FieldSnoop:Formatting ( fld / pos )
    (if (and (setq pos (vl-string-search "\\f \"" fld))
             (setq fld (substr fld (+ 5 pos))
                   pos (vl-string-search "\">%" fld)
             )
        )
        (cons (substr fld 1 pos)
              (FieldSnoop:Formatting (substr fld (+ 3 pos)))
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:FIELDSNOOP  -  main routine
;; ---------------------------------------------------------------------------
(defun c:FIELDSNOOP ( / *error* ent fld fmt )

    ;; Read-only: nothing in the drawing is altered, so no sysvars are captured
    ;; and no undo group is opened.
    (defun *error* ( msg )
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** FIELDSNOOP error: " msg " **"))
        )
        (princ)
    )

    ;; Re-prompt until something usable is picked, or the user gives up. Each
    ;; failure mode gets its own message so the user knows which of the four
    ;; things went wrong.
    (while
        (progn
            (setvar 'errno 0)
            (setq ent (nentsel "\nSelect a field to inspect: "))
            (cond
                ;; errno 7 means the click missed everything.
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )

                (   (null ent) nil)

                (   (progn
                        ;; A four-element nentsel return means the object is
                        ;; nested; the entity itself is then the last element
                        ;; of the last element.
                        (if (= 4 (length ent))
                            (setq ent (last (last ent)))
                            (setq ent (car ent))
                        )
                        (not (wcmatch (cdr (assoc 0 (entget ent)))
                                      "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION"))
                    )
                    (princ "\nThat object type cannot contain a field.")
                )

                (   (null (setq fld (FieldSnoop:Code ent)))
                    (princ "\nThat object does not contain a field.")
                )

                (   (null (setq fmt (last (FieldSnoop:Formatting fld))))
                    (princ "\nThat field has no formatting applied.")
                )
            )
        )
    )

    (if fmt
        (progn
            (princ "\nFormatting code: ")
            ;; prin1 rather than princ, so the code appears with its quotes and
            ;; any backslashes shown literally - ready to copy straight into
            ;; source code without having to re-escape it.
            (prin1 fmt)
        )
    )

    (princ)
)

(princ)