;;; ---------------------------------------------------------------------------
;;; WordSwap.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; COPY OR SWAP TEXT CONTENT BETWEEN ANY TWO OBJECTS
;;;
;;; Click one piece of text, click another, and the wording moves across.
;;; WORDCOPY sends the first object's text to the second; WORDSWAP exchanges
;;; the two.
;;;
;;; What makes this worth having is the range of things it treats as "text".
;;; All of these are interchangeable sources and destinations:
;;;
;;;   TEXT and MTEXT
;;;   block attributes
;;;   dimension text overrides
;;;   multileader text, and multileader block attributes
;;;   individual table cells
;;;
;;; So a room number can go straight from a table cell into a block
;;; attribute, or a dimension override can be copied into an mtext note,
;;; without retyping anything and without any of the usual copy-paste
;;; hazards.
;;;
;;; ---------------------------------------------------------------------------
;;; FORMATTING
;;;
;;; The hard part is not moving the characters, it is moving them between
;;; objects with different ideas about formatting.
;;;
;;; MText, multileaders, dimensions and table cells all understand inline
;;; formatting codes: colour changes, stacked fractions, underlining, font
;;; switches. Plain TEXT and ordinary attributes do not -- give them a
;;; formatted string and the raw codes appear on screen as gibberish.
;;;
;;; WordSwap therefore inspects both objects and converts appropriately:
;;;
;;;   formatted  -> formatted    the codes are carried across intact, if the
;;;                              Retain setting is Yes; otherwise they are
;;;                              stripped and only the words move
;;;   formatted  -> plain        the codes are stripped
;;;   plain      -> formatted    any characters that MText would misread as
;;;                              codes are escaped, so a backslash or a brace
;;;                              in the source survives as itself
;;;   plain      -> plain        copied verbatim
;;;
;;; The Retain setting is offered at every prompt by typing S, and is
;;; remembered between sessions.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW SELECTION WORKS
;;;
;;; Picking is done with a grread loop rather than entsel, for two reasons.
;;;
;;; First, table cells. entsel returns the table as a whole; the loop instead
;;; uses the table's own HitTest method to work out which row and column the
;;; click landed in, so a single cell can be addressed.
;;;
;;; Second, keywords. The loop reads typed characters as well as picks, which
;;; is what allows Settings, Multiple and Exit to be typed at the same prompt
;;; that is waiting for a click.
;;;
;;; Typed keywords are matched the way AutoCAD's own initget does: the
;;; capital letters of each option form its abbreviation, and any unambiguous
;;; prefix is accepted.
;;;
;;; ---------------------------------------------------------------------------
;;; MULTIPLE DESTINATIONS
;;;
;;; In WORDCOPY, typing M at the destination prompt switches to a normal
;;; window selection, so one source can be pushed into any number of
;;; destinations at once. Each destination is still converted according to
;;; its own formatting capability.
;;;
;;; ---------------------------------------------------------------------------
;;; REQUIREMENTS
;;;
;;; Formatting conversion uses the Windows VBScript regular expression
;;; engine, which is present on every standard Windows installation. If it
;;; cannot be reached the command reports so and stops rather than silently
;;; producing mangled text.
;;;
;;; ---------------------------------------------------------------------------
;;;   WORDCOPY - copy text content from one object to others
;;;   WORDSWAP - exchange the text content of two objects
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; Registry key holding the Retain-formatting preference, so the setting
;;; survives between drawings and sessions.
;;; ---------------------------------------------------------------------------

(setq *WordSwap:Key* "YZ\\WordSwapRetain")

;;; ---------------------------------------------------------------------------
;;; Runtime caches. Global because they are shared by both commands and must
;;; persist for the life of the session:
;;;
;;;   *WordSwap:RegExp*  the VBScript RegExp COM object, created once
;;;   *WordSwap:TagIds*  attribute definition IDs per block name, so a
;;;                      multileader block's tags are looked up only once
;;;   *WordSwap:Retain*  current formatting-retention setting
;;; ---------------------------------------------------------------------------

(setq *WordSwap:RegExp* nil
      *WordSwap:TagIds* nil
)
(or *WordSwap:Retain* (setq *WordSwap:Retain* "Yes"))

;;; ---------------------------------------------------------------------------
;;; WordSwap:Doc
;;;
;;; Returns the active document, caching itself after the first call.
;;; ---------------------------------------------------------------------------

(defun WordSwap:Doc nil
    (eval (list 'defun 'WordSwap:Doc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (WordSwap:Doc)
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:StartUndo / WordSwap:EndUndo
;;;
;;; Undo group control. EndUndo loops on bit 8 of UNDOCTL, which stays set
;;; while any group is open, so a group left open by an interrupted operation
;;; is also closed.
;;; ---------------------------------------------------------------------------

(defun WordSwap:EndUndo ( )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark (WordSwap:Doc))
    )
    (princ)
)

(defun WordSwap:StartUndo ( )
    (WordSwap:EndUndo)
    (vla-startundomark (WordSwap:Doc))
    (princ)
)

;;; ===========================================================================
;;;                          C O M M A N D S
;;; ===========================================================================

(defun c:WordCopy nil (WordSwap:Run nil))
(defun c:WordSwap nil (WordSwap:Run   t))

;;; ---------------------------------------------------------------------------
;;; WordSwap:Run
;;;
;;; The shared engine for both commands.
;;;
;;;   swap - nil to copy one source into many destinations,
;;;          T to exchange the content of two objects
;;;
;;; The two modes share all their machinery and differ only in what happens
;;; after the second object is picked, which is why they are one function.
;;; ---------------------------------------------------------------------------

(defun WordSwap:Run

    ( swap / *error* WordSwap:Restore WordSwap:Convert
        dest ent idx pick src srcfmt srcplain vals vars
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; WordSwap:Restore
    ;;;
    ;;; Releases the regular expression COM object and restores the drawing
    ;;; environment.
    ;;;
    ;;; Releasing matters: an unreleased COM object stays resident for the
    ;;; whole AutoCAD session. NOMUTT matters even more -- the selection
    ;;; helper silences AutoCAD while it runs, and leaving it silenced would
    ;;; make every later command appear broken.
    ;;; -----------------------------------------------------------------------

    (defun WordSwap:Restore ( )
        (if (and (= 'vla-object (type *WordSwap:RegExp*))
                 (not (vlax-object-released-p *WordSwap:RegExp*))
            )
            (progn
                (vlax-release-object *WordSwap:RegExp*)
                (setq *WordSwap:RegExp* nil)
            )
        )
        (WordSwap:EndUndo)
        (mapcar 'setvar vars vals)
        (princ)
    )

    (defun *error* ( msg )
        (WordSwap:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** " (if swap "WORDSWAP" "WORDCOPY") " error: " msg " **"))
        )
        (princ)
    )

    (setvar 'cmdecho 0)
    (WordSwap:StartUndo)

    ;; The attribute-tag cache is cleared per run, so a block redefined since
    ;; the last run is read afresh. Within one run it stays hot, which is
    ;; what keeps a multiple-destination pass fast.
    (setq *WordSwap:TagIds* nil)

    ;; Load the stored preference, defaulting to Yes on first use.
    (or (setq *WordSwap:Retain* (getenv *WordSwap:Key*))
        (setq *WordSwap:Retain* (setenv *WordSwap:Key* "Yes"))
    )

    (cond
        ;;  ---- the regular expression engine is essential ----
        (   (not (WordSwap:RegExp)))

        ;;  ---- pick the source ----
        (   (not (setq src (WordSwap:GetContent
                               (if swap
                                   "\nSelect text to swap [Settings/Exit] <Exit>: "
                                   "\nSelect source text [Settings/Exit]: "
                               )
                               "Settings Exit"
                           )
                 )
            )
        )

        ;;  ---- SWAP: pick the second object and exchange ----
        (   (and swap
                 (setq dest (WordSwap:GetContent
                                "\nAnd text to swap it with [Settings/Exit] <Exit>: "
                                "Settings Exit"
                            )
                 )
            )
            ;; Both strings are converted in both directions up front, then
            ;; the right pair is chosen according to what each object can
            ;; actually display.
            (   (lambda ( fmt1 fmt2 plain1 plain2 keep )
                    (mapcar 'WordSwap:SetContent (list src dest)
                        (cond
                            ;;  Both formatted, keeping formatting: the raw
                            ;;  strings pass straight across.
                            (   (and fmt1 fmt2 keep) (list (cadr dest) (cadr src)))
                            ;;  Both formatted, not keeping: strip, but leave
                            ;;  the codes escaped so nothing is misread.
                            (   (and fmt1 fmt2)      (list (car plain2) (car plain1)))
                            ;;  Source formatted, destination plain.
                            (   fmt1                 (list (car plain2) (cadr plain1)))
                            ;;  Source plain, destination formatted.
                            (   fmt2                 (list (cadr plain2) (car plain1)))
                            (   keep                 (list (cadr dest) (cadr src)))
                            (                        (list (cadr plain2) (cadr plain1)))
                        )
                    )
                    (princ "\nText swapped.")
                )
                (WordSwap:CanFormat (entget (car src)))
                (WordSwap:CanFormat (entget (car dest)))
                (WordSwap:Unformat  (cadr src)  (WordSwap:CanFormat (entget (car src))))
                (WordSwap:Unformat  (cadr dest) (WordSwap:CanFormat (entget (car dest))))
                (= "Yes" *WordSwap:Retain*)
            )
        )

        ;;  ---- COPY: keep pushing the source into destinations ----
        (   (not swap)
            (setq srcfmt   (WordSwap:CanFormat (entget (car src)))
                  srcplain (WordSwap:Unformat (cadr src) srcfmt)
            )

            ;; Picks the correct version of the source string for one
            ;; destination. Defined here rather than at file scope because it
            ;; closes over the source, which never changes during the loop.
            (defun WordSwap:Convert ( destfmt keep )
                (cond
                    (   (and srcfmt destfmt keep) (cadr src))
                    (   (and srcfmt destfmt)      (car  srcplain))
                    (   srcfmt                    (cadr srcplain))
                    (   destfmt                   (car  srcplain))
                    (   keep                      (cadr src))
                    (                             (cadr srcplain))
                )
            )

            (setq idx 0)
            (while (setq dest (WordSwap:GetContent
                                  "\nSelect destination text [Multiple/Settings/Exit] <Exit>: "
                                  "Multiple Settings Exit"
                              )
                   )
                (if (= 'pickset (type dest))
                    ;; A window selection: every object in it gets the source
                    ;; text, each converted for its own capability.
                    (repeat (setq pick (sslength dest))
                        (setq ent (ssname dest (setq pick (1- pick))))
                        (WordSwap:SetContent (list ent)
                            (WordSwap:Convert (WordSwap:CanFormat (entget ent))
                                              (= "Yes" *WordSwap:Retain*))
                        )
                        (setq idx (1+ idx))
                    )
                    ;; A single pick, which may carry table row and column.
                    (progn
                        (WordSwap:SetContent dest
                            (WordSwap:Convert (WordSwap:CanFormat (entget (car dest)))
                                              (= "Yes" *WordSwap:Retain*))
                        )
                        (setq idx (1+ idx))
                    )
                )
            )
            (princ (strcat "\n" (itoa idx) " object" (if (= 1 idx) "" "s") " updated."))
        )
    )

    (WordSwap:Restore)
    (princ)
)

;;; ===========================================================================
;;;                    K E Y W O R D   H A N D L I N G
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; WordSwap:Split
;;;
;;; Splits a delimited string into a list of substrings.
;;; ---------------------------------------------------------------------------

(defun WordSwap:Split ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos)
              (WordSwap:Split (substr str (+ pos 1 (strlen del))) del)
        )
        (list str)
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:ParseKeywords
;;;
;;; Turns an initget-style keyword string into a list of
;;; (wildcard-pattern . full-keyword) pairs.
;;;
;;; AutoCAD's convention is that the CAPITAL letters and digits of a keyword
;;; form its abbreviation: "Multiple" abbreviates to M, "LAyer" to LA. This
;;; extracts those characters and wraps them in wildcards, giving a pattern
;;; that recognises the abbreviation wherever it appears.
;;;
;;;   ini - space-separated keyword string, e.g. "Multiple Settings Exit"
;;; ---------------------------------------------------------------------------

(defun WordSwap:ParseKeywords ( ini )
    (mapcar
       '(lambda ( kwd )
            (cons
                (strcat "*"
                    (vl-list->string
                        (vl-remove-if-not
                            ;; 65-90 are A-Z, 48-57 are 0-9.
                           '(lambda ( c ) (or (< 64 c 91) (< 47 c 58)))
                            (vl-string->list kwd)
                        )
                    )
                    "*"
                )
                kwd
            )
        )
        (WordSwap:Split ini " ")
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:MatchKeyword
;;;
;;; Matches typed input against a keyword list and returns the full keyword,
;;; or nil.
;;;
;;; Two tests must both pass. The typed text must match the keyword's
;;; abbreviation pattern, AND the keyword must contain the typed text -- so
;;; "MULT" matches "Multiple" but "MX" does not, even though both begin with
;;; the abbreviation letter.
;;;
;;;   str - what the user typed
;;;   ini - the keyword string offered at this prompt
;;; ---------------------------------------------------------------------------

(defun WordSwap:MatchKeyword ( str ini )
    (setq str (strcase str))
    (cond
        (   (= "" str)  nil)
        (   (= "" ini)  str)
        (   (vl-some
               '(lambda ( kwd )
                    (if (and (wcmatch str (car kwd))
                             (wcmatch (strcase (cdr kwd)) (strcat "*" str "*"))
                        )
                        (cdr kwd)
                    )
                )
                (WordSwap:ParseKeywords ini)
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:Pick
;;;
;;; Waits for the user to either click an object or type a keyword.
;;;
;;; grread is used rather than entsel so that table cells can be resolved to
;;; a specific row and column, which entsel cannot do, and so that typed
;;; keywords can be accepted at a prompt that is also waiting for a pick.
;;;
;;; nentselp is tried first because it reaches inside blocks to individual
;;; attributes. If it finds nothing, every visible unlocked table is asked
;;; whether the click landed in one of its cells.
;;;
;;;   msg - prompt to display
;;;   ini - keywords accepted at this prompt
;;;
;;; Returns either a keyword string, or a list of (entity point ...).
;;; ---------------------------------------------------------------------------

(defun WordSwap:Pick ( msg ini / cell code data rtn str tables )
    (setq tables (WordSwap:VisibleTables)
          str    ""
    )
    (princ msg)
    (while
        (progn
            (setq data (grread nil 14 2)
                  code (car  data)
                  data (cadr data)
            )
            (cond
                ;;  ---- a pick ----
                (   (= 3 code)
                    (cond
                        (   (setq rtn (nentselp data)) nil)
                        (   (setq cell (WordSwap:HitCell tables data))
                            ;; The table object plus the click point; the row
                            ;; and column are resolved again downstream.
                            (setq rtn (list (vlax-vla-object->ename (car cell)) data))
                            nil
                        )
                        (   (princ (strcat "\nMissed, try again." msg)))
                    )
                )
                ;;  ---- a keystroke ----
                (   (= 2 code)
                    (cond
                        ;;  A printable character: echo it and buffer it.
                        (   (< 32 data 127)
                            (setq str (strcat str (princ (chr data))))
                        )
                        ;;  Enter or Space: try to resolve what was typed.
                        (   (or (= 13 data) (= 32 data))
                            (cond
                                (   (= "" str) nil)      ;; nothing typed: accept the default
                                (   (setq rtn (WordSwap:MatchKeyword str ini)) nil)
                                (   (princ (strcat "\nInvalid option keyword." msg))
                                    (setq str "")
                                )
                            )
                        )
                        ;;  Backspace: erase one character on screen and in
                        ;;  the buffer. 010 is backspace: back, space, back.
                        (   (and (= 8 data) (< 0 (strlen str)))
                            (setq str (substr str 1 (1- (strlen str))))
                            (princ "\010 \010")
                        )
                        (   t t)
                    )
                )
                ;;  ---- right-click, treated as Enter ----
                (   (= 25 code)
                    (cond
                        (   (= "" str) nil)
                        (   (setq rtn (WordSwap:MatchKeyword str ini)) nil)
                        (   (princ (strcat "\nInvalid option keyword." msg))
                            (setq str "")
                        )
                    )
                )
            )
        )
    )
    rtn
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:GetContent
;;;
;;; Wraps the pick loop with keyword handling and content extraction, and
;;; keeps asking until it has something usable.
;;;
;;; Returns one of:
;;;   * a list of (entity text [row col]) describing what was picked and the
;;;     text it currently holds
;;;   * a selection set, when Multiple was chosen
;;;   * nil, when the user exited
;;;
;;;   msg - prompt to display
;;;   ini - keywords accepted at this prompt
;;; ---------------------------------------------------------------------------

(defun WordSwap:GetContent ( msg ini / kwd rtn sel )
    (while
        (progn
            (setq sel (WordSwap:Pick
                          (strcat "\nFormatting retained: " *WordSwap:Retain* msg)
                          ini
                      )
            )
            (cond
                (   (or (null sel) (= "Exit" sel)) nil)

                ;;  Settings: change and re-prompt.
                (   (= "Settings" sel)
                    (initget "Yes No")
                    (if (setq kwd (getkword
                                      (strcat "\nRetain mtext formatting? [Yes/No] <"
                                              *WordSwap:Retain* ">: ")))
                        (setenv *WordSwap:Key* (setq *WordSwap:Retain* kwd))
                    )
                    t
                )

                ;;  Multiple: switch to a window selection. The filter accepts
                ;;  text, mtext, multileaders, dimensions, and blocks that
                ;;  carry attributes. "_:L" excludes locked layers, which
                ;;  could not be written to anyway.
                (   (= "Multiple" sel)
                    (not
                        (setq rtn
                            (WordSwap:Ssget "\nSelect destination text <back>: "
                               '(   "_:L"
                                    (
                                        (-4 . "<OR")
                                            (0 . "TEXT,MTEXT,MULTILEADER,*DIMENSION")
                                            (-4 . "<AND")
                                                (00 . "INSERT")
                                                (66 . 1)
                                            (-4 . "AND>")
                                        (-4 . "OR>")
                                    )
                                )
                            )
                        )
                    )
                )

                ;;  Bit 4 of DXF 70 on the layer record means locked.
                (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer"
                             (cdr (assoc 8 (entget (car sel)))))))))
                    (princ "\nThat object is on a locked layer.")
                )

                ;;  Extract the content; a nil result means try again.
                (   (null (setq rtn (WordSwap:ReadContent sel))))
            )
        )
    )
    rtn
)

;;; ===========================================================================
;;;                 R E A D I N G   A N D   W R I T I N G
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; WordSwap:ReadContent
;;;
;;; Returns (entity text [row col]) for whatever was picked, or nil.
;;;
;;; Each object type stores its text somewhere different, which is what this
;;; function exists to hide from the rest of the program:
;;;
;;;   TEXT           DXF group 1
;;;   MTEXT, ATTRIB  group 1, preceded by any number of group 3 continuation
;;;                  chunks when the string is longer than 250 characters
;;;   dimensions     group 1 when overridden; otherwise the measured value,
;;;                  which has to be read out of the dimension's own block
;;;   multileader    group 304 for text content, or a block attribute
;;;   block          one of its attributes, chosen by the user if there are
;;;                  several
;;;   table          a cell, addressed by row and column
;;;
;;;   sel - the pick result from WordSwap:Pick
;;; ---------------------------------------------------------------------------

(defun WordSwap:ReadContent ( sel / col con ent enx obj row tmp typ )

    ;; A click inside a table cell that contains mtext returns the mtext
    ;; through nentselp, with the table itself as the last element. The table
    ;; is the more useful handle, because writing to the cell keeps the
    ;; cell's own formatting rules; the same applies to dimension text.
    (if (and (= 4 (length sel))
             (= "MTEXT" (cdr (assoc 0 (entget (car sel)))))
             (wcmatch (cdr (assoc 0 (entget (car (last sel))))) "ACAD_TABLE,*DIMENSION")
        )
        (setq ent (car (last sel)))
        (setq ent (car sel))
    )
    (setq enx (entget ent)
          typ (cdr (assoc 0 enx))
    )

    (cond
        ;;  ---- table cell ----
        ;;  HitTest converts the click point into a row and column. The view
        ;;  direction is needed because the test is a ray cast, not a 2D
        ;;  point-in-rectangle test, so it works on a rotated view too.
        (   (= "ACAD_TABLE" typ)
            (if (= :vlax-true
                   (vla-hittest
                       (setq obj (vlax-ename->vla-object ent))
                       (vlax-3d-point (trans (cadr sel) 1 0))
                       (vlax-3d-point (trans (getvar 'viewdir) 1 0))
                       'row 'col
                   )
                )
                (list ent (vla-gettext obj row col) row col)
            )
        )

        (   (= "TEXT" typ)
            (list ent (cdr (assoc 1 enx)))
        )

        ;;  ---- dimension ----
        ;;  An empty group 1 means the dimension is showing its measured
        ;;  value, which is not stored as text anywhere on the dimension --
        ;;  it lives in the anonymous block that draws it.
        (   (wcmatch typ "*DIMENSION")
            (list ent
                (if (= "" (cdr (assoc 1 enx)))
                    (WordSwap:DimText (cdr (assoc 2 enx)))
                    (cdr (assoc 1 enx))
                )
            )
        )

        (   (wcmatch typ "ATTRIB,MTEXT")
            (list ent (WordSwap:LongText enx))
        )

        ;;  ---- multileader ----
        ;;  Group 172 states whether the content is mtext or a block. It is
        ;;  read from the reversed list because a multileader carries several
        ;;  172 groups and the last one is the content type.
        (   (= "MULTILEADER" typ)
            (setq con (cdr (assoc 172 (reverse enx))))
            (cond
                (   (= acmtextcontent con)
                    (list ent (cdr (assoc 304 enx)))
                )
                (   (= acblockcontent con)
                    (if (setq tmp (WordSwap:MLeaderAttribute (vlax-ename->vla-object ent)))
                        (cons ent tmp)
                    )
                )
            )
        )

        ;;  ---- attributed block ----
        (   (and (= "INSERT" typ) (= 1 (cdr (assoc 66 enx))))
            (WordSwap:BlockAttribute ent)
        )

        ;;  A four-element pick that fell through everything above: retry
        ;;  against the outer object instead of the nested one.
        (   (= 4 (length sel))
            (WordSwap:ReadContent (list (car (last sel)) (cadr sel)))
        )

        (   (princ "\nThat object has no editable text."))
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:SetContent
;;;
;;; Writes a string into whatever was picked.
;;;
;;;   lst - (entity [text] [row col]) as returned by WordSwap:ReadContent,
;;;         or simply (entity)
;;;   str - the string to write
;;; ---------------------------------------------------------------------------

(defun WordSwap:SetContent ( lst str / con enx obj owner tmp typ )
    (setq enx (entget (car lst))
          typ (cdr (assoc 0 enx))
          obj (vlax-ename->vla-object (car lst))
    )
    (cond
        (   (wcmatch typ "*TEXT,ATTRIB")
            (vla-put-textstring obj str)
        )

        (   (wcmatch typ "*DIMENSION")
            (vla-put-textoverride obj str)
        )

        ;;  A table cell may be individually locked even when the table and
        ;;  its layer are not, so that is checked before writing.
        (   (= "ACAD_TABLE" typ)
            (if (zerop (logand accellstatecontentlocked
                               (vla-getcellstate obj (caddr lst) (cadddr lst))))
                (vla-settext obj (caddr lst) (cadddr lst) str)
                (princ "\nThat table cell is locked.")
            )
        )

        ;;  Writing to a block writes to every one of its attributes that is
        ;;  writable, which is what makes the Multiple option useful on a run
        ;;  of single-attribute tags.
        (   (and (= "INSERT" typ) (= 1 (cdr (assoc 66 enx))))
            (foreach att (vlax-invoke obj 'getattributes)
                (if (vlax-write-enabled-p att)
                    (vla-put-textstring att str)
                )
            )
        )

        (   (= "MULTILEADER" typ)
            (setq con (cdr (assoc 172 (reverse enx))))
            (cond
                (   (= acmtextcontent con)
                    (vla-put-textstring obj str)
                )
                (   (= acblockcontent con)
                    (if (caddr lst)
                        ;; A specific attribute was chosen when reading.
                        (WordSwap:SetBlockAttribute obj (caddr lst) str)
                        ;; No specific attribute: write to all of them.
                        (foreach oid (WordSwap:AttributeTagIds (vla-get-contentblockname obj))
                            (WordSwap:SetBlockAttribute obj oid str)
                        )
                    )
                )
            )
        )
    )

    ;; ---- force a redraw where the change would not otherwise show --------
    ;; An object living inside a block (a dimension's own block, or a table's)
    ;; does not necessarily refresh on screen when its text changes. The
    ;; owner is found by walking past any application-defined data groups to
    ;; group 330, and its name checked: if it is not model or paper space,
    ;; the object is nested and a regen is needed.
    (while (setq tmp (member '(102 . "}") enx)) (setq enx (cdr tmp)))
    (if (and (setq owner (cdr (assoc 330 enx)))
             (setq owner (cdr (assoc 002 (entget owner))))
             (wcmatch (strcase owner t) "~`**_space*")
        )
        (vla-regen (WordSwap:Doc) acallviewports)
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:LongText
;;;
;;; Reassembles the full string of an MText or attribute.
;;;
;;; AutoCAD stores at most 250 characters in DXF group 1; anything longer is
;;; split, with the leading chunks in a series of group 3 entries and the
;;; final chunk in group 1. Reading group 1 alone would silently truncate a
;;; long note.
;;;
;;; The list is reversed so that walking forward from group 1 visits the
;;; group 3 chunks in reverse order, which is the order they must be
;;; prepended in.
;;; ---------------------------------------------------------------------------

(defun WordSwap:LongText ( enx / itm str )
    (setq enx (reverse enx)
          str (cdr (assoc 1 enx))
    )
    (while (setq itm (assoc 3 enx))
        (setq str (strcat (cdr itm) str)
              enx (cdr (member itm enx))
        )
    )
    str
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:DimText
;;;
;;; Returns the text a dimension is currently displaying, when it has no
;;; override of its own.
;;;
;;; The measured value is not stored on the dimension; it is drawn by an
;;; anonymous block whose name is in the dimension's group 2. Walking that
;;; block for its MText entity is the only way to recover the string that is
;;; actually on screen.
;;;
;;;   blk - the dimension's block name
;;; ---------------------------------------------------------------------------

(defun WordSwap:DimText ( blk / ent rtn )
    (if (setq ent (tblobjname "block" blk))
        (while (and (setq ent (entnext ent)) (null rtn))
            (if (= "MTEXT" (cdr (assoc 0 (entget ent))))
                (setq rtn (cadr (WordSwap:Unformat (WordSwap:LongText (entget ent)) t)))
            )
        )
    )
    rtn
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:BlockAttribute
;;;
;;; Returns (entity text) for one attribute of a block reference.
;;;
;;; A block with a single attribute needs no decision. A block with several
;;; puts them in a list box so the user can say which one they meant --
;;; guessing would be wrong half the time on a title block.
;;;
;;; Attributes follow their block reference in the database, so they are
;;; found by stepping forward with entnext until something that is not an
;;; ATTRIB appears.
;;; ---------------------------------------------------------------------------

(defun WordSwap:BlockAttribute ( ent / enx idx lst )
    (setq ent (entnext ent)
          enx (entget  ent)
    )
    (while (= "ATTRIB" (cdr (assoc 0 enx)))
        (setq lst (cons (list ent (WordSwap:LongText enx)) lst)
              ent (entnext ent)
              enx (entget  ent)
        )
    )
    (cond
        ;;  Exactly one attribute.
        (   (null (cdr (setq lst (reverse lst))))
            (car lst)
        )
        ;;  Several: ask. The list shows unformatted text so the user reads
        ;;  words rather than formatting codes.
        (   (setq idx
                (WordSwap:ListBox "Select attribute"
                    (mapcar
                       '(lambda ( itm )
                            (cadr (WordSwap:Unformat (cadr itm)
                                      (WordSwap:CanFormat (entget (car itm)))))
                        )
                        lst
                    )
                )
            )
            (nth idx lst)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:MLeaderAttribute
;;;
;;; Returns (text objectid) for one attribute of a block-content multileader.
;;;
;;; Multileader block attributes are not entities and cannot be reached with
;;; entnext. They are addressed by the object ID of the attribute DEFINITION
;;; inside the block, which is why the tag IDs have to be looked up first.
;;; ---------------------------------------------------------------------------

(defun WordSwap:MLeaderAttribute ( obj / idx lst )
    (setq lst
        (mapcar '(lambda ( oid ) (list (WordSwap:GetBlockAttribute obj oid) oid))
                (WordSwap:AttributeTagIds (vla-get-contentblockname obj))
        )
    )
    (cond
        (   (null lst)
            (princ "\nThat multileader has no editable content.")
        )
        (   (null (cdr lst)) (car lst))
        (   (setq idx
                (WordSwap:ListBox "Select attribute"
                    (mapcar '(lambda ( itm ) (cadr (WordSwap:Unformat (car itm) t))) lst)
                )
            )
            (nth idx lst)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:AttributeTagIds
;;;
;;; Returns the object IDs of every non-constant attribute definition in a
;;; block, which is how a multileader's block attributes are addressed.
;;;
;;; Walking a block definition is slow and the answer never changes within a
;;; run, so results are cached per block name. On its first call the function
;;; also REDEFINES ITSELF with the document object baked in as a literal,
;;; removing the ActiveX lookup from every later call.
;;;
;;;   blk - block name
;;; ---------------------------------------------------------------------------

(defun WordSwap:AttributeTagIds ( blk )
    (eval
        (list 'defun 'WordSwap:AttributeTagIds '( blk / lst )
            (list 'cond
               '(   (cdr (assoc (strcase blk) *WordSwap:TagIds*)))
                (list 't
                    (list 'vlax-for 'obj
                        (list 'vla-item
                            (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
                            'blk
                        )
                        ;; Constant attributes cannot be edited per insertion,
                        ;; so they are excluded.
                       '(if (and (= "AcDbAttributeDefinition" (vla-get-objectname obj))
                                 (= :vlax-false (vla-get-constant obj))
                            )
                            (setq lst (cons (WordSwap:ObjectId obj) lst))
                        )
                    )
                   '(setq *WordSwap:TagIds*
                        (cons (cons (strcase blk) (reverse lst)) *WordSwap:TagIds*)
                    )
                   '(WordSwap:AttributeTagIds blk)
                )
            )
        )
    )
    (WordSwap:AttributeTagIds blk)
)

;;; ---------------------------------------------------------------------------
;;; 64-bit safe ActiveX accessors.
;;;
;;; On 64-bit AutoCAD an object ID does not fit in a 32-bit integer, so the
;;; ordinary ObjectId property and the GetBlockAttributeValue method were
;;; supplemented with 32-suffixed versions that pass the value as a string.
;;; Which one exists depends on the release.
;;;
;;; Each function tests once, then redefines itself to the correct variant,
;;; so the test costs nothing after the first call.
;;; ---------------------------------------------------------------------------

(defun WordSwap:ObjectId ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun WordSwap:ObjectId ( obj ) (vla-get-objectid32 obj))
        (defun WordSwap:ObjectId ( obj ) (vla-get-objectid   obj))
    )
    (WordSwap:ObjectId obj)
)

(defun WordSwap:GetBlockAttribute ( obj oid )
    (if (vlax-method-applicable-p obj 'getblockattributevalue32)
        (defun WordSwap:GetBlockAttribute ( obj oid ) (vla-getblockattributevalue32 obj oid))
        (defun WordSwap:GetBlockAttribute ( obj oid ) (vla-getblockattributevalue   obj oid))
    )
    (WordSwap:GetBlockAttribute obj oid)
)

(defun WordSwap:SetBlockAttribute ( obj oid str )
    (if (vlax-method-applicable-p obj 'setblockattributevalue32)
        (defun WordSwap:SetBlockAttribute ( obj oid str )
            (vla-setblockattributevalue32 obj oid str)
        )
        (defun WordSwap:SetBlockAttribute ( obj oid str )
            (vla-setblockattributevalue   obj oid str)
        )
    )
    (WordSwap:SetBlockAttribute obj oid str)
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:ListBox
;;;
;;; Shows a simple list and returns the index chosen, or nil.
;;;
;;; The dialog definition is written to a uniquely named temporary file,
;;; loaded, and deleted immediately. A unique name means two AutoCAD sessions
;;; running at once cannot collide over it.
;;;
;;;   msg - dialog title
;;;   lst - strings to list
;;; ---------------------------------------------------------------------------

(defun WordSwap:ListBox ( msg lst / dch des rtn tmp )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat
                            "listbox: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 "listbox" dch)
                )
            )
            (princ "\nUnable to open the selection list.")
        )
        (   t
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            ;; Pre-select the first entry so OK works straight away.
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn (if (= 1 (start_dialog)) (atoi rtn)))
        )
    )
    (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

;;; ===========================================================================
;;;                        F O R M A T T I N G
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; WordSwap:CanFormat
;;;
;;; Returns non-nil if the object understands inline formatting codes.
;;;
;;; Tables, mtext, multileaders and dimensions always do. An attribute does
;;; only when it is a multiline attribute, which is recognised by the
;;; "Embedded Object" marker in its entity data.
;;; ---------------------------------------------------------------------------

(defun WordSwap:CanFormat ( enx )
    (or (wcmatch (cdr (assoc 0 enx)) "ACAD_TABLE,MTEXT,MULTILEADER,*DIMENSION")
        (and (= "ATTRIB" (cdr (assoc 0 enx)))
             (member '(101 . "Embedded Object") enx)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:RegExp
;;;
;;; Returns the shared VBScript regular expression object, creating it on
;;; first use.
;;;
;;; A regular expression engine is used because MText formatting codes cannot
;;; be removed by simple string search: they are variable-length, nestable,
;;; and one of them (\S for stacked fractions) has to be rewritten rather
;;; than deleted. Doing that by hand in AutoLISP would be many times the code
;;; and considerably slower.
;;;
;;; Three properties are set:
;;;   Global      replace every occurrence, not just the first
;;;   IgnoreCase  off, because \P and \p mean different things
;;;   Multiline   so ^ and $ work per line within a paragraph
;;; ---------------------------------------------------------------------------

(defun WordSwap:RegExp ( / rgx )
    (cond
        (   *WordSwap:RegExp*)
        (   (or (null (setq rgx (vl-catch-all-apply 'vlax-get-or-create-object
                                                   '("vbscript.regexp"))))
                (vl-catch-all-error-p rgx)
            )
            (princ (strcat "\nUnable to reach the regular expression engine: "
                           (vl-catch-all-error-message rgx)))
            nil
        )
        (   t
            (vlax-put-property rgx 'global     actrue)
            (vlax-put-property rgx 'ignorecase acfalse)
            (vlax-put-property rgx 'multiline  actrue)
            (setq *WordSwap:RegExp* rgx)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:Unformat
;;;
;;; Strips MText formatting codes from a string and returns TWO versions of
;;; the result:
;;;
;;;   (car result)   safe to write into a formatted object. Any character
;;;                  that MText would read as a code -- a backslash, a brace
;;;                  -- is escaped so it survives as itself.
;;;   (cadr result)  safe to write into a plain object. Nothing is escaped;
;;;                  what you see is what is stored.
;;;
;;; Both are produced because the caller does not know which it needs until
;;; it has looked at the destination, and computing both costs one extra
;;; pass over a short string.
;;;
;;;   str - the string to strip
;;;   mtx - non-nil if the string came from a formatted object, which decides
;;;         which set of patterns applies
;;;
;;; ---------------------------------------------------------------------------
;;; ABOUT THE PATTERNS
;;;
;;; Character 032 (ASCII SUB) is used throughout as a placeholder for a
;;; backslash. Backslashes are simultaneously the MText escape character and
;;; the regular expression escape character, so leaving them in place while
;;; other patterns run would corrupt them. They are parked as 032, the other
;;; passes run safely, and they are restored at the end.
;;;
;;; The formatted-source patterns, in order:
;;;   1. park literal double backslashes as 032
;;;   2. turn paragraph, newline and tab codes into spaces
;;;   3. remove the formatting codes: alignment, colour, font, height,
;;;      kerning, tracking, obliquing, overline, paragraph, quality,
;;;      tracking, width -- both the escaped and unescaped forms
;;;   4. rewrite stacked fractions \S1/2; as plain 1/2
;;;   5. remove the stack marker and closing braces
;;;   6. remove opening braces
;;;
;;; The plain-source patterns simply park backslashes and remove the
;;; overline and underline toggles %%o and %%u.
;;;
;;; The whole thing is wrapped in a catch: a malformed string can make the
;;; regular expression engine throw, and one bad label must not abort the
;;; command.
;;; ---------------------------------------------------------------------------

(defun WordSwap:Unformat ( str mtx / rtn )
    (setq rtn
        (vl-catch-all-apply
           '(lambda nil
                ;; ---- pass 1: strip the formatting ----
                (foreach pair
                    (if mtx
                       '(
                            ("\032"     . "\\\\\\\\")
                            (" "        . "\\\\P|\\n|\\t")
                            ("$1"       . "\\\\(\\\\[ACcFfHKkLlOopQTW])|\\\\[ACcFfHKkLlOopQTW][^\\\\;]*;|\\\\[ACcFfKkHLlOopQTW]")
                            ("$1$2/$3"  . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                            ("$1$2"     . "\\\\(\\\\S)|[\\\\](})|}")
                            ("$1"       . "[\\\\]({)|{")
                        )
                       '(
                            ("\032"     . "\\\\")
                            (""         . "%%[OoUu]")
                        )
                    )
                    (vlax-put-property (WordSwap:RegExp) 'pattern (cdr pair))
                    (setq str (vlax-invoke (WordSwap:RegExp) 'replace str (car pair)))
                )
                ;; ---- pass 2: produce the two output versions ----
                (mapcar
                   '(lambda ( patterns / out )
                        (setq out str)
                        (foreach pair patterns
                            (vlax-put-property (WordSwap:RegExp) 'pattern (cdr pair))
                            (setq out (vlax-invoke (WordSwap:RegExp) 'replace out (car pair)))
                        )
                        out
                    )
                   '(
                        ;; Escaped version: re-escape anything MText would
                        ;; misread, then restore the parked backslashes as
                        ;; escaped pairs.
                        (
                            ("\\$1$2$3" . "(\\\\[ACcFfHKkLlOoPpQSTW])|({)|(})")
                            ("\\\\"     . "\032")
                        )
                        ;; Plain version: restore the parked backslashes as
                        ;; single characters.
                        (
                            ("\\"       . "\032")
                        )
                    )
                )
            )
        )
    )
    ;; On failure return the original string in both slots, so the caller
    ;; always gets something usable.
    (if (vl-catch-all-error-p rtn)
        (list str str)
        rtn
    )
)

;;; ===========================================================================
;;;                            T A B L E S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; WordSwap:HitCell
;;;
;;; Returns (table row column) for whichever supplied table the point lands
;;; in, or nil.
;;;
;;; HitTest is a ray cast along the view direction rather than a flat
;;; point-in-rectangle test, which is why it works in a rotated or
;;; three-dimensional view as well as plan.
;;; ---------------------------------------------------------------------------

(defun WordSwap:HitCell ( tables pnt / dir )
    (setq dir (vlax-3d-point (trans (getvar 'viewdir) 1 0))
          pnt (vlax-3d-point pnt)
    )
    (vl-some
       '(lambda ( tab / row col )
            (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
                (list tab row col)
            )
        )
        tables
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:VisibleTables
;;;
;;; Returns every table in the current layout that could actually be clicked
;;; on: not on a frozen, off or locked layer, and not itself invisible.
;;;
;;; The filtering is done inside the ssget call rather than afterwards
;;; because a drawing can hold a great many tables and testing them one at a
;;; time on every mouse click would be visibly slow.
;;;
;;; Layers are excluded by building a NOT-OR filter listing every layer that
;;; is off (negative colour) or frozen or locked (bits 1 and 4 of DXF 70).
;;; Layer names can legitimately contain wildcard characters, so each is
;;; escaped before it goes into the filter.
;;; ---------------------------------------------------------------------------

(defun WordSwap:VisibleTables ( / idx lst obj sel )
    (setq sel
        (ssget "_X"
            (vl-list*
               '(000 . "ACAD_TABLE")
                ;; CVPORT 1 means paper space is active, so only the current
                ;; layout's tables are relevant.
                (if (= 1 (getvar 'cvport))
                    (cons 410 (getvar 'ctab))
                   '(410 . "Model")
                )
                (   (lambda ( / def out )
                        (while (setq def (tblnext "layer" (not def)))
                            (if (or (minusp (cdr (assoc 62 def)))          ;; layer off
                                    (< 0 (logand 5 (cdr (assoc 70 def))))  ;; frozen or locked
                                )
                                (setq out (cons (cons 8 (WordSwap:EscapeWild (cdr (assoc 2 def)))) out))
                            )
                        )
                        (if out
                            (append '((-4 . "<NOT") (-4 . "<OR"))
                                    out
                                   '((-4 . "OR>") (-4 . "NOT>"))
                            )
                        )
                    )
                )
            )
        )
    )
    (if sel
        (repeat (setq idx (sslength sel))
            (setq idx (1- idx)
                  obj (vlax-ename->vla-object (ssname sel idx))
            )
            (if (= :vlax-true (vla-get-visible obj))
                (setq lst (cons obj lst))
            )
        )
    )
    lst
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:EscapeWild
;;;
;;; Escapes every character that ssget's filter syntax treats as a wildcard,
;;; by preceding it with a backquote.
;;;
;;; Without this a layer genuinely named "A-Wall*" would match far more
;;; layers than intended, and one named "A,B" would be read as two separate
;;; names.
;;;
;;; The escaped characters are  # @ . * ? ~ [ ] - ,
;;; ---------------------------------------------------------------------------

(defun WordSwap:EscapeWild ( str )
    (vl-list->string
        (apply 'append
            (mapcar
               '(lambda ( c )
                    (if (member c '(35 64 46 42 63 126 91 93 45 44))
                        (list 96 c)     ;; 96 is the backquote
                        (list c)
                    )
                )
                (vl-string->list str)
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; WordSwap:Ssget
;;;
;;; A quiet ssget: prints its own prompt and silences AutoCAD's while the
;;; selection is made, so the caller's message is not buried under the
;;; standard "Select objects:" text.
;;;
;;; NOMUTT is restored immediately, and is also held in the calling command's
;;; saved variable list so that an error part-way through cannot leave
;;; AutoCAD permanently silent.
;;; ---------------------------------------------------------------------------

(defun WordSwap:Ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

(princ "\nWordSwap loaded. WORDCOPY to copy text content, WORDSWAP to exchange it.")
(princ)

;;; ---------------------------------------------------------------------------
;;; End of file
;;; ---------------------------------------------------------------------------