Einzeilige Texte zu einem mehrzeiligen Text verbinden

Reiner Text, nichts ist versteckt. Kopieren Sie ihn in eine Datei namens cxt2m.lsp oder laden Sie ihn herunter.

;;; ============================================================================
;;; CXT2M - Merge single-line texts into one MTEXT
;;; Version 1.0.0
;;; CADXChange LISP tools - https://cadxchange.net/resources/lisp/cxt2m
;;; Tested in: AutoCAD (full version). Other programs that run AutoLISP may work but are not tested.
;;; Copyright (c) CADXChange. Free for personal and commercial use; do not resell or
;;; republish it as a collection. Terms: https://cadxchange.net/legal/lisp-terms
;;; ============================================================================

;; Merge the texts in NAMES into one MTEXT: the lines run from the top row to the bottom row, each row left to right.
;; The new MTEXT takes layer, style, height and color from the first line and sits where that line was.
;; DELETE = T erases the original texts. Returns the new entity, or nil.
(defun cx:t2m-run (names delete / items tol sorted first ed line lines pt h)
  (setq items  (mapcar (function (lambda (e) (cons (cx:text-pt (entget e)) e))) names)
        tol    (* 0.6 (/ (apply '+ (mapcar (function (lambda (e) (cx:dxf 40 (entget e)))) names)) (length names)))
        sorted (mapcar 'cdr (cx:sort-grid items 1 T 0 nil tol))
        first  (car sorted)
        ed     (entget first)
        h      (cx:dxf 40 ed))
  (foreach e sorted
    (setq line (cx:text-get e))
    ;; Characters that mean something in MTEXT are escaped in a single-line TEXT
    (if (= (cx:dxf 0 (entget e)) "TEXT")
      (setq line (cx:replace (cx:replace (cx:replace line "\\" "\\\\") "{" "\\{") "}" "\\}")))
    (setq lines (cons line lines)))
  (setq lines (reverse lines)
        pt    (cx:dxf 10 ed)
        pt    (if (= (cx:dxf 0 ed) "TEXT") (list (car pt) (+ (cadr pt) h) (caddr pt)) pt))
  (setq first
    (entmakex
      (append
        (list '(0 . "MTEXT") '(100 . "AcDbEntity") (cons 8 (cx:dxf 8 ed)))
        (if (cx:dxf 62 ed) (list (cons 62 (cx:dxf 62 ed))))
        (list '(100 . "AcDbMText") (cons 10 pt) (cons 40 h) '(41 . 0.0) '(71 . 1) '(72 . 5) '(1 . "")
              (cons 7 (if (cx:dxf 7 ed) (cx:dxf 7 ed) "STANDARD"))))))
  (if first
    (progn
      (cx:text-set first (cx:join lines "\\P"))
      (if delete (foreach e sorted (entdel e)))))
  first)

(defun c:CXT2M ( / *error* cx:sv ss del ent)
  (setq *error* cx:err)
  (if (setq ss (cx:pick "\nSelect the texts to merge: " '((0 . "TEXT,MTEXT"))))
    (progn
      (setq del (= (cx:ask-kw "Erase the original texts" "Yes No" "Yes") "Yes"))
      (cx:start '(("CMDECHO" . 0)))
      (if (setq ent (cx:t2m-run (cx:ss->list ss) del))
        (princ (strcat "\n" (itoa (sslength ss)) " text(s) merged into one MTEXT."))
        (princ "\nThe MTEXT could not be created."))
      (cx:end)))
  (princ))


;;; ---- Shared helpers (used by the command above; identical in every CADXChange tool) ----

(defun cx:dxf (code ed)
  (cdr (assoc code ed)))

;; The point a TEXT, MTEXT or ATTRIB sits at (the alignment point when it is aligned).
(defun cx:text-pt (ed)
  (if (and (member (cx:dxf 0 ed) '("TEXT" "ATTRIB" "ATTDEF"))
           (or (/= 0 (cx:dxf 72 ed)) (/= 0 (cx:dxf 73 ed)))
           (cx:dxf 11 ed))
    (cx:dxf 11 ed)
    (cx:dxf 10 ed)))

;; Merge sort of LST with PRED (a function of two items that is true when the first goes first).
(defun cx:sort (lst pred / half a b out)
  (cond
    ((or (null lst) (null (cdr lst))) lst)
    (T
     (setq half (/ (length lst) 2) a nil b lst)
     (repeat half (setq a (cons (car b) a) b (cdr b)))
     (setq a (cx:sort (reverse a) pred) b (cx:sort b pred) out nil)
     (while (and a b)
       (if (apply pred (list (car b) (car a)))
         (setq out (cons (car b) out) b (cdr b))
         (setq out (cons (car a) out) a (cdr a))))
     (append (reverse out) a b))))

;; Sort ITEMS ((point . data) ...) into rows or columns: first by AXIS1 (0 = X, 1 = Y; DESC1 = T for large to small),
;; items whose AXIS1 values differ by less than TOL stay in one group, and each group is sorted by AXIS2.
(defun cx:sort-grid (items axis1 desc1 axis2 desc2 tol / sorted groups cur ref out)
  (setq sorted (cx:sort items
                 (function (lambda (a b)
                   (if desc1
                     (> (nth axis1 (car a)) (nth axis1 (car b)))
                     (< (nth axis1 (car a)) (nth axis1 (car b))))))))
  (foreach it sorted
    (if (and cur (<= (abs (- (nth axis1 (car it)) ref)) tol))
      (setq cur (cons it cur))
      (progn
        (if cur (setq groups (cons (reverse cur) groups)))
        (setq cur (list it) ref (nth axis1 (car it))))))
  (if cur (setq groups (cons (reverse cur) groups)))
  (foreach g (reverse groups)
    (setq out (append out
                (cx:sort g
                  (function (lambda (a b)
                    (if desc2
                      (> (nth axis2 (car a)) (nth axis2 (car b)))
                      (< (nth axis2 (car a)) (nth axis2 (car b))))))))))
  out)

;; The text of a TEXT, ATTRIB, ATTDEF or MTEXT (MTEXT keeps its codes).
(defun cx:text-get (ename / ed s)
  (setq ed (entget ename))
  (if (= (cx:dxf 0 ed) "MTEXT")
    (progn
      (setq s "")
      (foreach p ed (if (= (car p) 3) (setq s (strcat s (cdr p)))))
      (strcat s (cx:dxf 1 ed)))
    (cx:dxf 1 ed)))

;; Replace every OLD in STR by NEW (case sensitive).
(defun cx:replace (str old new / n out pos)
  (setq n (strlen old) out "" pos 1)
  (if (= n 0)
    str
    (progn
      (while (<= pos (1+ (- (strlen str) n)))
        (if (= (substr str pos n) old)
          (setq out (strcat out new) pos (+ pos n))
          (setq out (strcat out (substr str pos 1)) pos (1+ pos))))
      (strcat out (substr str pos)))))

;; Replace the text of a TEXT, ATTRIB, ATTDEF or MTEXT.
(defun cx:text-set (ename str / ed out)
  (setq ed (entget ename))
  (if (= (cx:dxf 0 ed) "MTEXT")
    (progn
      ;; MTEXT stores text in 250-character pieces: 3 groups for the first pieces, 1 for the last
      (foreach p ed (if (not (member (car p) '(1 3))) (setq out (cons p out))))
      (setq out (reverse out))
      (while (> (strlen str) 250)
        (setq out (append out (list (cons 3 (substr str 1 250)))) str (substr str 251)))
      (setq ed (append out (list (cons 1 str)))))
    (setq ed (subst (cons 1 str) (assoc 1 ed) ed)))
  (entmod ed)
  (entupd ename)
  T)

(defun cx:join (lst delim / out)
  (setq out "")
  (foreach s lst
    (setq out (if (= out "") s (strcat out delim s))))
  (if lst out ""))

;; Close the undo step and put the system variables back.
(defun cx:end ()
  (foreach v cx:sv (setvar (car v) (cdr v)))
  (command "_.UNDO" "_End")
  (setq cx:sv nil)
  (princ))

;; Error handler: restores everything, stays quiet on Esc.
(defun cx:err (msg)
  (if (> (getvar "CMDACTIVE") 0) (command))
  (cx:end)
  (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg)))
  (princ))

;; Use the objects already selected, or ask the user to select; FILTER is an ssget filter list or nil.
(defun cx:pick (msg filter / ss)
  (setq ss (if filter (ssget "_I" filter) (ssget "_I")))
  (if (null ss)
    (progn
      (princ msg)
      (setq ss (if filter (ssget filter) (ssget)))))
  ss)

;; Ask for one of the keywords in BITS ("Yes No"), default DEF; returns the keyword.
(defun cx:ask-kw (msg bits def / v)
  (initget 0 bits)
  (setq v (getkword (strcat "\n" msg " [" (cx:replace bits " " "/") "] <" def ">: ")))
  (if v v def))

;; Save the system variables in VARS ((name . value) ...), set them, and open one undo step.
;; The caller declares cx:sv as a local so the saved values live exactly as long as the command.
(defun cx:start (vars)
  (setq cx:sv (mapcar (function (lambda (v) (cons (car v) (getvar (car v))))) vars))
  (command "_.UNDO" "_Begin")
  (foreach v vars (setvar (car v) (cdr v)))
  (princ))

;; Selection set to a list of entity names.
(defun cx:ss->list (ss / i out)
  (setq i 0)
  (if ss
    (repeat (sslength ss)
      (setq out (cons (ssname ss i) out)
            i   (1+ i))))
  (reverse out))

(princ "\nCXT2M loaded. Type CXT2M to start.")
(princ)

Weitere Befehle: Text

• CXNUMTexte fortlaufend nummerieren
• CXTXTADDVielen Texten ein Präfix oder Suffix hinzufügen
• CXTXTCUTZeichen am Anfang oder Ende von Texten abschneiden
• CXTXTCASEGroß- und Kleinschreibung vieler Texte ändern
• CXTXTREPLIn vielen Texten gleichzeitig suchen und ersetzen
• CXTXTCLEANLeerzeichen und Formatierung in Texten aufräumen
• CXM2TMehrzeiligen Text in einzeilige Texte zerlegen
• CXTXTALIGNTexte an einem Bezugstext ausrichten
• CXTXTSTYLETextstil und Texthöhe für viele Texte ändern
• CXTXTCOUNTGleiche Texte zählen
• CXTXTSUMZahlen in Texten addieren