;;; ---------------------------------------------------------------------------
;;; TextWeld.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Merges separate Text and MText objects into a single MText, in the order
;;; YOU pick them, preserving each one's formatting.
;;;
;;; Similar to the Express Tools TXT2MTXT command, but with control over the
;;; order and over whether each piece starts a new line or continues the
;;; previous one - which is what makes it usable on a schedule or a note block
;;; that has been drawn as thirty separate lines of text.
;;;
;;; HOW TO USE IT
;;;   1. Pick the first text object. It becomes the new MText.
;;;   2. Keep picking further text. Each is appended and the original removed.
;;;   3. Move the mouse to position the result, and click to place it.
;;;
;;; WHILE PICKING
;;;   SPACE        toggles between New Line and Same Line mode
;;;   U            undoes the last pick
;;;   SHIFT-click  appends the text but KEEPS the original in place
;;;   click empty  starts a window selection to add many at once
;;;   ENTER        finishes
;;;
;;; The shift-click option needs Express Tools; without it, everything else
;;; still works and shift is simply ignored.
;;;
;;; FORMATTING IS PRESERVED
;;; Where a picked object differs from the MText being built, the difference is
;;; written in as an MText formatting code and wrapped in braces so it applies
;;; only to that piece:
;;;
;;;     \C<n>;    colour
;;;     \H<n>x;   height, as a multiple of the current height
;;;     \F<font>; font
;;;     \L \l     underline on and off, converted from the old %%U codes
;;;
;;; So a merged block of text keeps its varying sizes and colours rather than
;;; being flattened to the first object's formatting.
;;;
;;;   TEXTWELD  - merge text objects into one MText
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Mode names, indexed by the mode flag: 0 is new line, 1 is same line.
(setq TextWeld:Modes '("New Line " "Same Line"))

;; ---------------------------------------------------------------------------
;; Line mode, remembered between runs. Global by necessity - it must outlive
;; the command that sets it.
;; ---------------------------------------------------------------------------
(or *TextWeld:Mode* (setq *TextWeld:Mode* 0))

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

;; ---------------------------------------------------------------------------
;; TextWeld:Attachment
;; ---------------------------------------------------------------------------
;; Returns the MText attachment point matching an object's justification.
;;
;; MText uses a 1-9 grid; Text uses a different numbering in which 0-2 are the
;; baseline row, 3-5 are the fitted and aligned special cases, and 6 upwards
;; are the middle and top rows. The three cases below map one to the other:
;;
;;   0-2  baseline left/centre/right  ->  1+ the value, giving the top row
;;   3-5  aligned, middle, fit        ->  1, since these have no direct MText
;;                                        equivalent
;;   6+   the remaining rows          ->  the value less 5
;; ---------------------------------------------------------------------------
(defun TextWeld:Attachment ( obj / al )
    (cond
        (   (= "AcDbMText" (vla-get-ObjectName obj))
            (vla-get-AttachmentPoint obj)
        )
        (   (= "AcDbText" (vla-get-ObjectName obj))
            (setq al (vla-get-Alignment obj))
            (cond
                ((<= 0 al 2) (1+ al))
                ((<= 3 al 5) 1)
                (t (- al 5))
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; TextWeld:CursorPoint
;; ---------------------------------------------------------------------------
;; Returns where the MText's insertion point must sit so that the object
;; appears to hang correctly from the cursor.
;;
;; The insertion point of an MText is its attachment corner, not its centre, so
;; without this correction a middle-attached MText would jump half its own
;; height away from the cursor. The offset is applied along the object's own
;; rotation, so it stays correct for rotated text.
;;
;; obj - [vla-object] the MText being dragged
;; pt  - [list] cursor position, WCS
;; ---------------------------------------------------------------------------
(defun TextWeld:CursorPoint ( obj pt / lower upper al rot )
    (vla-getBoundingBox obj 'lower 'upper)
    (setq lower (vlax-safearray->list lower)
          upper (vlax-safearray->list upper)
          al    (vla-get-AttachmentPoint obj)
          rot   (vla-get-rotation obj)
    )
    (cond
        ;; Top row - offset by one text height.
        (   (member al (list acAttachmentPointTopLeft
                             acAttachmentPointTopCenter
                             acAttachmentPointTopRight))
            (polar pt (- rot (/ pi 2.0)) (vla-get-Height obj))
        )
        ;; Middle row - one height plus half the object's own height.
        (   (member al (list acAttachmentPointMiddleLeft
                             acAttachmentPointMiddleCenter
                             acAttachmentPointMiddleRight))
            (polar pt (- rot (/ pi 2.0))
                   (+ (vla-get-Height obj)
                      (/ (- (cadr upper) (cadr lower)) 2.0)
                   )
            )
        )
        ;; Bottom row - one height plus the object's full height.
        (   (member al (list acAttachmentPointBottomLeft
                             acAttachmentPointBottomCenter
                             acAttachmentPointBottomRight))
            (polar pt (- rot (/ pi 2.0))
                   (+ (vla-get-Height obj)
                      (- (cadr upper) (cadr lower))
                   )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; TextWeld:Width
;; ---------------------------------------------------------------------------
;; Returns the display width of a text object.
;;
;; MText reports its width directly. Text does not, so the width is measured
;; with textbox - with "..." prepended, which forces textbox to account for the
;; leading space that a bare measurement would otherwise omit, and so avoids
;; the merged MText coming out slightly too narrow and wrapping.
;; ---------------------------------------------------------------------------
(defun TextWeld:Width ( obj / enx box )
    (cond
        (   (= "AcDbText" (vla-get-objectname obj))
            (setq enx (entget (vlax-vla-object->ename obj))
                  box (textbox
                          (subst (cons 1 (strcat "..." (cdr (assoc 1 enx))))
                                 (assoc 1 enx)
                                 enx
                          )
                      )
            )
            (- (caadr box) (caar box))
        )
        (   (vla-get-Width obj))
    )
)

;; ---------------------------------------------------------------------------
;; TextWeld:ConvertUnderline
;; ---------------------------------------------------------------------------
;; Converts the old Text underline code %%U into the MText equivalents.
;;
;; %%U is a TOGGLE - the first turns underlining on, the next turns it off.
;; MText instead uses \L to start and \l to stop, so the occurrences are walked
;; in order and alternated between the two. If an odd number is found the
;; underline was left on, so a closing \l is appended.
;; ---------------------------------------------------------------------------
(defun TextWeld:ConvertUnderline ( str / idx under )
    (if (vl-string-search "%%U" (strcase str))
        (progn
            (setq idx 0)
            (while (and (< idx (strlen str))
                        (setq idx (vl-string-search "%%U" (strcase str) idx))
                   )
                (if under
                    (setq str   (strcat (substr str 1 idx) "\\l" (substr str (+ idx 4)))
                          idx   (+ idx 4)
                          under nil
                    )
                    (setq str   (strcat (substr str 1 idx) "\\L" (substr str (+ idx 4)))
                          idx   (+ idx 4)
                          under t
                    )
                )
            )
            (if under (setq str (strcat str "\\l")))
        )
    )
    str
)

;; ---------------------------------------------------------------------------
;; TextWeld:WindowSelect
;; ---------------------------------------------------------------------------
;; Draws a rubber-band selection box from a corner and returns the objects
;; caught within it.
;;
;; Dragging left produces a CROSSING selection, dragging right a WINDOW one -
;; matching AutoCAD's own convention, which is detected from the sign of the
;; horizontal movement. The box is drawn as four vectors in green or blue to
;; match that convention too.
;; ---------------------------------------------------------------------------
(defun TextWeld:WindowSelect ( msg pt filter / gr data pt1 pt2 lst )
    (princ msg)

    (while (and (= 5 (car (setq gr (grread t 13 0))))
                (listp (setq data (cadr gr)))
           )
        (redraw)
        (setq pt1 (list (car data) (cadr pt)   (caddr data))
              pt2 (list (car pt)   (cadr data) (caddr data))
        )
        (grvecs
            (setq lst
                (list (if (minusp (- (car data) (car pt))) -30 30)
                      pt pt1  pt pt2  pt1 data  pt2 data
                )
            )
        )
    )

    (redraw)
    (ssget (if (minusp (car lst)) "_C" "_W") pt data filter)
)

;; ---------------------------------------------------------------------------
;; TextWeld:Append
;; ---------------------------------------------------------------------------
;; Appends one text object's content to the MText being built.
;;
;; The state lists are passed and returned rather than being reached for at
;; global scope - the original relied on dynamic scoping to see the caller's
;; variables, which works but makes the data flow invisible.
;;
;; Formatting codes are only inserted where the source DIFFERS from the target,
;; and the whole piece is then wrapped in braces so the change does not leak
;; into the following text.
;;
;; Returns an updated state list: (lengths widths erased lastHeight)
;;
;;   lengths     - MText length before each append, for the undo option
;;   widths      - MText width before each append, likewise
;;   erased      - originals removed, nil where one was kept by shift-click
;;   lastHeight  - height of the previous piece, so consecutive pieces at the
;;                 same non-default height do not each re-declare it
;; ---------------------------------------------------------------------------
(defun TextWeld:Append ( target ent state keep / new str formatted lengths widths erased lastheight )

    (setq lengths    (nth 0 state)
          widths     (nth 1 state)
          erased     (nth 2 state)
          lastheight (nth 3 state)
    )

    ;; Record the state before the append, so it can be undone.
    (setq lengths (cons (strlen (vla-get-TextString target)) lengths)
          widths  (cons (vla-get-Width target) widths)
    )

    (setq new       (vlax-ename->vla-object ent)
          str       (vla-get-TextString new)
          formatted nil
    )

    ;; Same Line mode adds widths together; New Line mode takes the greater of
    ;; the two, since the pieces sit above one another.
    (vla-put-Width target
        ((if (= *TextWeld:Mode* 1) + max)
         (vla-get-Width target)
         (TextWeld:Width new)
        )
    )

    ;; Colour. 255 and 0 are BYLAYER and BYBLOCK, which carry no explicit
    ;; colour to transfer.
    (if (not (or (= (vla-get-Color new) (vla-get-Color target))
                 (member (vla-get-Color new) '(255 0))
             )
        )
        (setq str       (strcat "\\C" (itoa (vla-get-Color new)) ";" str)
              formatted t
        )
    )

    (setq str (TextWeld:ConvertUnderline str))

    ;; Height, expressed as a MULTIPLE of the current height - which is what
    ;; the trailing "x" means - so it scales correctly if the MText is later
    ;; resized.
    (if (not (or (= (vla-get-Height new) (vla-get-Height target))
                 (and lastheight (= (vla-get-Height new) lastheight))
             )
        )
        (setq str        (strcat "\\H"
                                 (rtos (/ (float (vla-get-Height new))
                                          (cond (lastheight) ((vla-get-Height target)))
                                       ) 2 2
                                 )
                                 "x;" str
                         )
              lastheight (vla-get-Height new)
              formatted  t
        )
    )

    ;; Font, taken from the style's font file rather than the style name, since
    ;; MText formatting codes name the font directly.
    (if (not (= (vla-get-StyleName new) (vla-get-StyleName target)))
        (setq str (strcat "\\F"
                          (vla-get-fontfile
                              (vla-item (vla-get-TextStyles (TextWeld:Doc))
                                        (vla-get-StyleName new)
                              )
                          )
                          ";" str
                  )
              formatted t
        )
    )

    ;; Braces confine every code above to this piece alone.
    (if formatted (setq str (strcat "{" str "}")))

    (vla-put-TextString target
        (strcat (vla-get-TextString target)
                (if (zerop *TextWeld:Mode*)
                    (strcat "\\P" str)                              ; \P is a paragraph break
                    (strcat " " (vl-string-left-trim (chr 32) str)) ; trim, then one space
                )
        )
    )
    (vla-update target)

    ;; Keep or remove the original, recording which so undo can restore it.
    (if keep
        (setq erased (cons nil erased))
        (progn (entdel ent) (setq erased (cons ent erased)))
    )

    (list lengths widths erased lastheight)
)

;; ---------------------------------------------------------------------------
;; c:TEXTWELD  -  main routine
;; ---------------------------------------------------------------------------
(defun c:TEXTWELD ( / *error* vars vals space express ent obj target shift
                      state lengths widths erased msg gr code data hit sel idx
                      undone )

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

    (defun TextWeld:Restore ( )
        (redraw)
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    ;; On failure the part-built MText is removed and every consumed original
    ;; restored, so an interrupted run leaves the drawing exactly as it was.
    (defun *error* ( msg )
        (if (and target (= 'vla-object (type target)) (not (vlax-erased-p target)))
            (vla-delete target)
        )
        (foreach e (vl-remove-if 'null (nth 2 state))
            (entdel e)
        )
        (TextWeld:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** TEXTWELD error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (setq space
        (if (or (= AcModelSpace (vla-get-activespace (TextWeld:Doc)))
                (= :vlax-true   (vla-get-MSpace (TextWeld:Doc)))
            )
            (vla-get-modelspace (TextWeld:Doc))
            (vla-get-paperspace (TextWeld:Doc))
        )
    )

    ;; Shift-click detection needs an Express Tools function; without it the
    ;; feature is simply unavailable rather than erroring.
    (setq express
        (and (vl-position "acetutil.arx" (arx))
             (not (vl-catch-all-error-p
                      (vl-catch-all-apply
                          (function (lambda nil (acet-sys-shift-down)))
                      )
                  )
             )
        )
    )

    ;; Pick the first object, which seeds the new MText.
    (while
        (progn
            (setq ent (car (entsel "\nSelect first text or mtext [shift-click to keep original]: ")))
            (if express (setq shift (acet-sys-shift-down)))
            (cond
                ((not ent) (princ "\nNothing selected."))
                ((not (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT"))
                 (princ "\nThat object is not text.")
                )
            )
        )
    )

    ;; 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 obj    (vlax-ename->vla-object ent)
          target (vla-AddMText space
                     (vla-get-InsertionPoint obj)
                     (TextWeld:Width obj)
                     (TextWeld:ConvertUnderline (vla-get-TextString obj))
                 )
    )

    ;; Inherit the source's basic properties.
    (foreach p '(InsertionPoint Layer Color StyleName Height)
        (vlax-put-property target p (vlax-get-property obj p))
    )

    ;; Text rotation is measured from the UCS X axis while MText rotation is
    ;; measured from world, so the UCS rotation is subtracted out for Text.
    (vla-put-rotation target
        (if (= "AcDbText" (vla-get-ObjectName obj))
            (- (vla-get-rotation obj)
               (angle '(0.0 0.0 0.0)
                      (trans (getvar 'UCSXDIR) 0 (trans '(0.0 0.0 1.0) 1 0 t))
               )
            )
            (vla-get-rotation obj)
        )
    )
    (vla-put-AttachmentPoint target (TextWeld:Attachment obj))

    ;; state is (lengths widths erased lastHeight)
    (setq state (list nil nil nil nil))
    (if shift
        (setq state (list nil nil (list nil) nil))
        (progn (entdel ent) (setq state (list nil nil (list ent) nil)))
    )

    (setq msg
        (strcat "\n  Mode: " (nth *TextWeld:Mode* TextWeld:Modes)
                "   [SPACE to change]"
                "\n  Select text to add  |  shift-click keeps the original"
                "  |  U undoes  |  ENTER places the mtext"
        )
    )
    (princ msg)

    ;; -----------------------------------------------------------------------
    ;; Main input loop. grread returns a code and a value:
    ;;   5  mouse moved      - reposition the MText under the cursor
    ;;   3  click            - add the text there, or start a window selection
    ;;   2  keypress         - SPACE toggles mode, U undoes, ENTER finishes
    ;;   25 right-click      - finish
    ;; -----------------------------------------------------------------------
    (while
        (progn
            (setq gr   (grread t 15 2)
                  code (car gr)
                  data (cadr gr)
            )
            (cond
                (   (and (= 5 code) (listp data))
                    (vla-put-InsertionPoint target
                        (vlax-3D-point (TextWeld:CursorPoint target (trans data 1 0)))
                    )
                    t
                )

                (   (and (= 3 code) (listp data))
                    (if (and (setq hit (car (nentselp data)))
                             (wcmatch (cdr (assoc 0 (entget hit))) "*TEXT")
                        )
                        ;; Clicked on text - append it.
                        (setq state
                            (TextWeld:Append target hit state
                                (and express (acet-sys-shift-down))
                            )
                        )
                        ;; Clicked empty space - offer a window selection. The
                        ;; MText is hidden meanwhile so it cannot select itself.
                        (progn
                            (vla-put-Visible target :vlax-false)
                            (if (setq sel (TextWeld:WindowSelect "\nPick opposite corner: "
                                                                 data '((0 . "TEXT,MTEXT"))))
                                (progn
                                    (setq idx -1)
                                    (while (setq hit (ssname sel (setq idx (1+ idx))))
                                        (setq state (TextWeld:Append target hit state nil))
                                    )
                                    (princ msg)
                                )
                                (princ (strcat "\nNo text selected." msg))
                            )
                            (vla-put-Visible target :vlax-true)
                        )
                    )
                    t
                )

                (   (= 25 code) nil)          ; right-click finishes

                (   (= 2 code)
                    (cond
                        (   (= 13 data) nil)  ; Enter finishes

                        ;; SPACE toggles between the two line modes.
                        (   (= 32 data)
                            (setq *TextWeld:Mode* (- 1 *TextWeld:Mode*)
                                  msg (strcat "\n  Mode: " (nth *TextWeld:Mode* TextWeld:Modes)
                                              "   [SPACE to change]"
                                              "\n  Select text to add  |  shift-click keeps the original"
                                              "  |  U undoes  |  ENTER places the mtext"
                                      )
                            )
                            (princ msg)
                            t
                        )

                        ;; U or u undoes the last append: the MText is truncated
                        ;; back to its recorded length and width, and the
                        ;; original object restored if it had been erased.
                        (   (member data '(85 117))
                            (setq lengths (nth 0 state)
                                  widths  (nth 1 state)
                                  erased  (nth 2 state)
                            )
                            (if (< 1 (length erased))
                                (progn
                                    (vla-put-TextString target
                                        (substr (vla-get-TextString target) 1 (car lengths))
                                    )
                                    (vla-put-Width target (car widths))
                                    (if (car erased) (entdel (car erased)))
                                    (setq state (list (cdr lengths) (cdr widths) (cdr erased) (nth 3 state))
                                          undone t
                                    )
                                )
                                (progn
                                    (princ "\nNothing to undo.")
                                    (princ msg)
                                )
                            )
                            t
                        )

                        (t t)
                    )
                )

                (t t)
            )
        )
    )

    (princ (strcat "\n" (itoa (length (nth 2 state))) " text objects merged."))

    ;; Cleared so the error handler's cleanup does not remove the finished work
    ;; if anything goes wrong during the restore.
    (setq target nil
          state  (list nil nil nil nil)
    )

    (TextWeld:Restore)
    (princ)
)

(princ)