;;; ---------------------------------------------------------------------------
;;; FormatBrush.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Copies the FORMATTING of one field onto other fields - a match-properties
;;; brush for field number formatting.
;;;
;;; Pick a field that displays exactly the way you want - the right units, the
;;; right precision, the right suffix - then keep clicking other fields and
;;; each takes on that same formatting while keeping its OWN value.
;;;
;;; The cursor changes to the match-properties brush while destinations are
;;; being picked, so it is obvious the tool is live.
;;;
;;; WHAT IS COPIED, AND WHAT IS NOT
;;; Only the formatting code is transferred - the part of a field expression
;;; that says how to display the number, not what number to display. So a field
;;; showing an area and one showing a length can share formatting without
;;; either changing what it reports.
;;;
;;; A DELIBERATE RESTRAINT WITH NESTED FIELDS
;;; A field can contain other fields. Where a NESTED field already has its own
;;; formatting, that formatting is replaced. But a nested field with NO
;;; formatting is left alone, and formatting is only ADDED at the top level.
;;;
;;; That distinction matters: adding formatting to an inner field that never had
;;; any would change how the outer calculation reads its value, quietly altering
;;; the result rather than just its appearance.
;;;
;;;   FORMATBRUSH  - copy field formatting from one field to others
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Object types that can carry a field.
(setq FormatBrush:Types "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION")

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

;; ---------------------------------------------------------------------------
;; FormatBrush:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string, using GetObjectIdString on 64-bit where
;; available. The test runs once, then this function replaces itself.
;; ---------------------------------------------------------------------------
(defun FormatBrush:ObjectID ( obj )
    (eval
        (list 'defun 'FormatBrush:ObjectID '( obj )
            (if (and (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                     (vlax-method-applicable-p
                         (vla-get-utility (FormatBrush:Doc)) 'getobjectidstring
                     )
                )
                (list 'vla-getobjectidstring
                      (vla-get-utility (FormatBrush:Doc)) 'obj ':vlax-false
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (FormatBrush:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; FormatBrush:Code
;; ---------------------------------------------------------------------------
;; Returns the fully resolved field expression held by an entity, or nil.
;;
;; A field is not stored in the visible object - the object holds a placeholder
;; and the expression lives in an ACAD_FIELD dictionary hanging off it, split
;; across multiple DXF entries when over 250 characters, and referring to other
;; objects and fields by internal indices.
;;
;; Three nested helpers reassemble it: FormatBrush:Assemble stitches the fragments back
;; together, FormatBrush:SwapObjs resolves object references to real IDs, and FormatBrush:SwapFlds
;; recurses into nested field dictionaries.
;; ---------------------------------------------------------------------------
(defun FormatBrush:Code ( ent / FormatBrush:SwapFlds FormatBrush:SwapObjs FormatBrush:Assemble enx )

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

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

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

    (if (and (wcmatch (cdr (assoc 0 (setq enx (entget ent)))) FormatBrush:Types)
             (setq enx (cdr (assoc 360 enx)))
             (setq enx (dictsearch enx "ACAD_FIELD"))
             (setq enx (dictsearch (cdr (assoc -1 enx)) "TEXT"))
        )
        (FormatBrush:SwapFlds (FormatBrush:Assemble enx) enx)
    )
)

;; ---------------------------------------------------------------------------
;; FormatBrush:Formatting
;; ---------------------------------------------------------------------------
;; Returns every formatting code in a field expression, in order.
;;
;; Formatting is introduced by \f " and terminated by ">%, so the codes are the
;; substrings between those delimiters. The caller takes the FIRST, which is
;; the outermost - the one governing how the finished value displays.
;; ---------------------------------------------------------------------------
(defun FormatBrush: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)
              (FormatBrush:Formatting (substr fld (+ 3 pos)))
        )
    )
)

;; ---------------------------------------------------------------------------
;; FormatBrush:Replace
;; ---------------------------------------------------------------------------
;; Returns the field expression with its formatting replaced by new.
;;
;; The function walks the string tracking nesting depth in idx: "%<" opens a
;; field and increments it, ">%" closes one and decrements it. Three cases at
;; each closing marker:
;;
;;   1. This field already has formatting (\f " appears before the close) -
;;      replace it, whatever the depth.
;;
;;   2. This field has NO formatting and is at depth 1, i.e. top level - insert
;;      the formatting.
;;
;;   3. This field has no formatting and is nested - leave it alone. See the
;;      note in the header for why this restraint matters.
;;
;; The final else-branch returns the remaining text unchanged, which preserves
;; any literal text following the last field in the object.
;;
;; str - [str] the field expression
;; new - [str] the formatting code to apply
;; idx - [int] current nesting depth; start at 0
;; ---------------------------------------------------------------------------
(defun FormatBrush:Replace ( str new idx / p q r )
    (setq p (vl-string-search "%<" str)
          q (vl-string-search ">%" str)
    )
    (if (or (and p q (< p q)) (and p (not q)))
        ;; An opening marker comes first - descend a level.
        (strcat (substr str 1 (+ p 2))
                (FormatBrush:Replace (substr str (+ p 3)) new (1+ idx))
        )
        (if q
            (cond
                ;; Case 1 - existing formatting, replace it.
                (   (and (setq r (vl-string-search "\\f \"" str)) (< r q))
                    (strcat (substr str 1 (+ r 4)) new "\">%"
                            (FormatBrush:Replace (substr str (+ q 3)) new (1- idx))
                    )
                )
                ;; Case 2 - top-level field without formatting, add it.
                (   (= 1 idx)
                    (strcat (substr str 1 q) " \\f \"" new "\">%"
                            (FormatBrush:Replace (substr str (+ q 3)) new (1- idx))
                    )
                )
                ;; Case 3 - nested and unformatted, leave alone.
                (   (strcat (substr str 1 (+ q 2))
                            (FormatBrush:Replace (substr str (+ q 3)) new (1- idx))
                    )
                )
            )
            str
        )
    )
)

;; ---------------------------------------------------------------------------
;; FormatBrush:Cursor
;; ---------------------------------------------------------------------------
;; Draws the match-properties brush icon at the cursor.
;;
;; The vector list is a hand-plotted bitmap of the standard brush, in pairs of
;; start and end points preceded by a colour index. It is scaled to the current
;; view so it stays the same apparent size at any zoom - which is what the
;; ratio of view size to screen size computes.
;; ---------------------------------------------------------------------------
(defun FormatBrush:Cursor ( p / r )
    (setq r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          p (trans p 0 2)
    )
    (grvecs
       '(
            251 (20 -10) (21 -10) 253 (22 -10) (22 -10)
            251 (19 -11) (19 -11) 007 (20 -11) (20 -11)
            253 (21 -11) (21 -12) 251 (22 -11) (22 -12)
            251 (14 -12) (16 -12) 251 (18 -12) (18 -12)
            007 (19 -12) (19 -12) 253 (20 -12) (20 -13)
            251 (13 -13) (13 -13) 007 (14 -13) (16 -13)
            251 (17 -13) (17 -13) 007 (18 -13) (18 -13)
            253 (19 -13) (19 -14) 251 (21 -13) (21 -13)
            034 (11 -14) (14 -14) 007 (15 -14) (15 -14)
            253 (16 -14) (17 -14) 251 (18 -14) (18 -14)
            251 (20 -14) (20 -14) 034 (09 -15) (14 -15)
            251 (15 -15) (15 -15) 007 (16 -15) (16 -15)
            253 (17 -15) (18 -15) 251 (19 -15) (19 -15)
            034 (06 -16) (15 -16) 251 (16 -16) (16 -16)
            253 (17 -16) (19 -16) 034 (06 -17) (16 -17)
            251 (17 -17) (17 -17) 253 (18 -17) (19 -17)
            034 (07 -18) (14 -18) 251 (15 -18) (15 -18)
            034 (16 -18) (16 -18) 251 (17 -18) (18 -18)
            253 (19 -18) (19 -18) 034 (08 -19) (15 -19)
            251 (16 -19) (16 -20) 034 (17 -19) (17 -19)
            251 (18 -19) (18 -19) 034 (09 -20) (09 -20)
            251 (10 -20) (10 -20) 034 (11 -20) (13 -20)
            251 (14 -20) (14 -20) 034 (15 -20) (15 -20)
            034 (10 -21) (10 -21) 251 (11 -21) (11 -21)
            034 (12 -21) (12 -21) 251 (13 -21) (13 -21)
            034 (14 -21) (14 -21) 251 (15 -21) (15 -21)
        )
        (list (list r 0.0 0.0 (car  p))
              (list 0.0 r 0.0 (cadr p))
              (list 0.0 0.0 r 0.0)
             '(0.0 0.0 0.0 1.0)
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:FORMATBRUSH  -  main routine
;; ---------------------------------------------------------------------------
(defun c:FORMATBRUSH ( / *error* vars vals ent fld src obj msg input point count )

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

    (defun FormatBrush:Restore ( )
        ;; redraw clears any brush icon left on screen.
        (redraw)
        (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 )
        (FormatBrush:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** FORMATBRUSH error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; -----------------------------------------------------------------------
    ;; Pick the source, re-prompting with a specific message for each of the
    ;; four ways it can be unsuitable.
    ;; -----------------------------------------------------------------------
    (while
        (progn
            (setvar 'errno 0)
            (setq ent (nentsel "\nSelect the source field: "))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'list (type ent))
                    (cond
                        (   (progn
                                (if (= 4 (length ent))
                                    (setq ent (last (last ent)))
                                    (setq ent (car ent))
                                )
                                (not (wcmatch (cdr (assoc 0 (entget ent))) FormatBrush:Types))
                            )
                            (princ "\nThat object type cannot contain a field.")
                        )
                        (   (null (setq fld (FormatBrush:Code ent)))
                            (princ "\nThat object does not contain a field.")
                        )
                        (   (null (setq src (car (FormatBrush:Formatting fld))))
                            (princ "\nThat field has no formatting to copy.")
                        )
                    )
                )
            )
        )
    )

    (if (= 'str (type src))
        (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 count 0)
            (princ (setq msg "\nSelect destination field <exit>: "))

            ;; -------------------------------------------------------------
            ;; grread reads raw input rather than using a normal prompt, which
            ;; is what allows the brush icon to be redrawn as the mouse moves.
            ;;
            ;;   code 5 - the cursor moved: redraw the brush at the new point
            ;;   code 3 - a click: try to apply the formatting there
            ;;   anything else - exit the loop
            ;; -------------------------------------------------------------
            (while
                (member
                    (setq input (grread t 13 2)
                          point (cadr input)
                          input (car  input)
                    )
                   '(3 5)
                )
                (if (= 5 input)
                    (progn
                        (redraw)
                        (FormatBrush:Cursor (trans point 1 0))
                    )
                    (cond
                        (   (null (setq ent (nentselp point)))
                            (princ (strcat "\nMissed, try again." msg))
                        )
                        (   (progn
                                (if (= 4 (length ent))
                                    (setq ent (last (last ent)))
                                    (setq ent (car ent))
                                )
                                (not (wcmatch (cdr (assoc 0 (entget ent))) FormatBrush:Types))
                            )
                            (princ (strcat "\nThat object type cannot contain a field." msg))
                        )
                        (   (null (vlax-write-enabled-p (setq obj (vlax-ename->vla-object ent))))
                            (princ (strcat "\nThat object is on a locked layer." msg))
                        )
                        (   (null (setq fld (FormatBrush:Code ent)))
                            (princ (strcat "\nThat object does not contain a field." msg))
                        )

                        ;; Dimensions store their text in TextOverride, other
                        ;; objects in TextString. In both cases the property is
                        ;; cleared first - writing a new field expression over
                        ;; an existing one without clearing can leave the old
                        ;; field's evaluated remains behind.
                        (   (vlax-property-available-p obj 'textoverride t)
                            (vla-put-textoverride obj "")
                            (vla-put-textoverride obj (FormatBrush:Replace fld src 0))
                            (setq count (1+ count))
                            nil
                        )
                        (   (vlax-property-available-p obj 'textstring t)
                            (vla-put-textstring obj "")
                            (vla-put-textstring obj (FormatBrush:Replace fld src 0))
                            (setq count (1+ count))
                            nil
                        )
                    )
                )
            )

            (princ (strcat "\nFormatting applied to " (itoa count)
                           " field" (if (= 1 count) "" "s") "."
                   )
            )
        )
        (princ "\n*Cancelled* - no source formatting found.")
    )

    (FormatBrush:Restore)
    (princ)
)

(princ)