;;; ---------------------------------------------------------------------------
;;; TextClone.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; MATCHPROP for text specifically - copies text FORMATTING from one object to
;;; many others.
;;;
;;; Standard MATCHPROP copies layer, colour and linetype but leaves height,
;;; style, rotation, width factor, oblique angle and justification exactly as
;;; they were, which is almost never what you want when tidying annotation.
;;; This copies all of them.
;;;
;;; Works with Text, MText, attributes and attribute definitions. The
;;; destination selection is automatically filtered to the same entity type as
;;; the source, so picking an MText as source will only match other MText.
;;;
;;; THE TEXT VALUE IS NEVER COPIED
;;; TextString is deliberately absent from the property list. Formatting is
;;; copied; content is not. A tool that silently overwrote text content while
;;; claiming to fix formatting would be genuinely dangerous - annotation is
;;; data.
;;;
;;; WHY JUSTIFICATION NEEDS SPECIAL HANDLING
;;; Changing Alignment or AttachmentPoint MOVES the object, because the text
;;; then hangs off a different corner of itself. So for those two properties
;;; the current insertion point is captured first, the property applied, and
;;; the position written back - which changes the justification while leaving
;;; the text visually where it was.
;;;
;;; That in turn requires care over WHICH position property to read, since Text
;;; stores its position in InsertionPoint when left-justified but in
;;; TextAlignmentPoint otherwise, while MText always uses InsertionPoint.
;;;
;;; THE PROPERTY LIST IS MEANT TO BE EDITED
;;; Delete a line from TextClone:Properties to stop that property being copied.
;;; Run XRAY on a text object to see the full set of names available.
;;;
;;;   TEXTCLONE  - match text formatting from a source to many targets
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; Properties copied from source to target. TextString is intentionally
;; excluded - see the header.
;; ---------------------------------------------------------------------------
(setq TextClone:Properties
   '(
        Alignment              ; justification (Text)
        AttachmentPoint        ; justification (MText)
        BackgroundFill
        Backward
        DrawingDirection
        Height
        Layer
        LineSpacingDistance
        LineSpacingFactor
        LineSpacingStyle
        Linetype
        LinetypeScale
        Lineweight
        ObliqueAngle
        Rotation
        ScaleFactor            ; width factor
        StyleName
        Thickness
        UpsideDown
        Width
    )
)

;; Properties that shift the object when changed, and therefore need the
;; position preserved around them.
(setq TextClone:Repositioning '(Alignment AttachmentPoint))

;; ---------------------------------------------------------------------------
;; TextClone:PositionProperty
;; ---------------------------------------------------------------------------
;; Returns which property actually holds this object's position.
;;
;; MText always uses InsertionPoint. Text uses InsertionPoint only when it is
;; left, fit or aligned; every other justification stores its true position in
;; TextAlignmentPoint, leaving InsertionPoint stale.
;;
;; Reading or writing the wrong one is why naive text routines appear to work
;; on some objects and silently do nothing on the rest.
;; ---------------------------------------------------------------------------
(defun TextClone:PositionProperty ( obj )
    (if (or (= "AcDbMText" (vla-get-ObjectName obj))
            (vl-position (vla-get-Alignment obj)
                         (list acAlignmentLeft acAlignmentFit acAlignmentAligned)
            )
        )
        'InsertionPoint
        'TextAlignmentPoint
    )
)

(defun TextClone:GetPosition ( obj )
    (vlax-get-property obj (TextClone:PositionProperty obj))
)

(defun TextClone:PutPosition ( obj pt )
    (vlax-put-property obj (TextClone:PositionProperty obj) pt)
)

;; ---------------------------------------------------------------------------
;; TextClone:PickSource
;; ---------------------------------------------------------------------------
;; Prompts until a valid text-bearing object is picked, or the user gives up.
;; Returns the entity name, or nil.
;; ---------------------------------------------------------------------------
(defun TextClone:PickSource ( / ent )
    (while
        (progn
            (setq ent (car (nentsel "\nSelect source text object: ")))
            (cond
                ((null ent) nil)
                ((wcmatch (cdr (assoc 0 (entget ent))) "TEXT,MTEXT,ATTRIB,ATTDEF") nil)
                (t (princ "\nThat is not a text object - try again.") t)
            )
        )
    )
    ent
)

;; ---------------------------------------------------------------------------
;; TextClone:Apply
;; ---------------------------------------------------------------------------
;; Applies one captured property value to a target object.
;;
;; Guarded individually, because not every property is available on every
;; object - MText has no ObliqueAngle, an attribute definition has no Width -
;; and a locked layer or a read-only property will refuse the write. A failure
;; on one property must not abandon the rest.
;;
;; The t argument to vlax-property-available-p tests specifically for WRITE
;; access, not merely existence.
;; ---------------------------------------------------------------------------
(defun TextClone:Apply ( obj prop val / result )
    (setq result
        (vl-catch-all-apply
            (function
                (lambda ( )
                    (if (and val (vlax-property-available-p obj prop t))
                        (if (vl-position prop TextClone:Repositioning)
                            ;; Justification change - preserve position across it.
                            (   (lambda ( pt )
                                    (vlax-put-property obj prop val)
                                    (TextClone:PutPosition obj pt)
                                )
                                (TextClone:GetPosition obj)
                            )
                            (vlax-put-property obj prop val)
                        )
                    )
                )
            )
        )
    )
    (not (vl-catch-all-error-p result))
)

;; ---------------------------------------------------------------------------
;; c:TEXTCLONE  -  main routine
;; ---------------------------------------------------------------------------
;; Note that the original left its NOMUTT holding variable undeclared, leaking
;; it into the global namespace on every run. It is properly localised here.
;; ---------------------------------------------------------------------------
(defun c:TEXTCLONE ( / *error* vars vals source object values sel idx ent count )

    ;; NOMUTT is suppressed around the destination selection so that the
    ;; running "Select objects:" chatter does not bury the prompt telling the
    ;; user which entity type is now being matched.
    (setq vars '("CMDECHO" "NOMUTT")
          vals (mapcar 'getvar vars)
    )

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

    (setvar "CMDECHO" 0)

    (if (and (setq source (TextClone:PickSource))
             (progn
                 (setq object (vlax-ename->vla-object source))
                 (setvar "NOMUTT" 1)
                 (princ (strcat "\nSelect destination "
                                (cdr (assoc 0 (entget source)))
                                " objects: "
                        )
                 )
                 ;; Filtered to the source's own entity type, so mismatched
                 ;; targets cannot be selected at all.
                 (setq sel (ssget "_:L" (list (assoc 0 (entget source)))))
                 (setvar "NOMUTT" (cadr vals))
                 sel
             )
        )
        (progn
            ;; Read the source once, up front - not once per target.
            (setq values
                (mapcar
                    (function
                        (lambda ( prop )
                            (if (vlax-property-available-p object prop)
                                (vlax-get-property object prop)
                            )
                        )
                    )
                    TextClone:Properties
                )
                count 0
            )

            ;; 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 idx 0)
            (while (setq ent (ssname sel idx))
                (mapcar
                    (function
                        (lambda ( prop val )
                            (TextClone:Apply (vlax-ename->vla-object ent) prop val)
                        )
                    )
                    TextClone:Properties
                    values
                )
                (setq count (1+ count)
                      idx   (1+ idx)
                )
            )

            (princ (strcat "\n" (itoa count)
                           " object" (if (= 1 count) "" "s") " matched."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (TextClone:Restore)
    (princ)
)

;; Short alias, matching the original's two-command arrangement.
(defun c:TXC nil (c:TEXTCLONE))

(princ)