Hier noch eine Lösung die ich gefunden habe.
(defun c:StripBlockMtext (/ adoc text_style_name text_height)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark adoc)
(vlax-for blk (vla-get-blocks adoc)
;; Exclude model and paper spaces and anonymus blocks
(if (and (equal (vla-get-IsLayout blk) :vlax-false)
(equal (vla-get-IsXref blk) :vlax-false)
(/= (substr (vla-get-Name blk) 1 1) "*")
)
(vlax-for ent blk
(if (= (vla-get-objectname ent) "AcDbMText")
(progn
(setq str (strip_text (vla-get-textstring ent) "*"))
(vl-catch-all-apply 'vla-put-textstring (list ent str))
)
)
)
)
)
(vla-regen adoc acactiveviewport)
(vla-endundomark adoc)
(princ)
)
(defun strip_text (str fmt / skipcnt ndx newlst char fmtcode lst_len
IS_MTEXT LST NEXTCHR PT TMP)
(if (or (/= (type fmt) 'Str) (= fmt "*") (= fmt ""))
(setq fmt (vl-string->list "AaCcFfHhLlOoPpQqSsTtQqWw~%"))
(setq fmt (vl-string->list fmt))
)
(setq ndx 0
;; "fmtcode" is a list of code flags that will end with ;
fmtcode
(vl-string->list "CcFfHhTQqWwAa") ;("\C" "\F" "\H" "\T" "\Q" "\W" "\A")
)
(if (/= str "") ; skip if empty text ""
(progn
(setq lst (vl-string->list str)
lst_len (length lst)
newlst '()
is_mtext nil ; true if mtext
)
(while (< ndx lst_len)
;; step through text and find FORMAT CHARACTERS
(setq char (nth ndx lst) ; Get next character
nextchr (nth (1+ ndx) lst)
skipcnt 0
)
(cond
((and (= char 123) (= nextchr 92)) ; "{\" mtext code
(setq is_mtext t
skipcnt 1
)
)
((and (= char 125) is_mtext) ; "}"
(setq skipcnt 1)
)
((= char 37) ; code start with "%"
(if (null nextchr) ; true if % is last char in text
(setq skipcnt 1)
;; Dtext codes
(if (= nextchr 37) ; %% code found
(if (< 47 (nth (+ ndx 2) lst) 58) ; is a number
(if (vl-position 37 fmt)
;; number found so fmtcode %%nnn
;; convert the nnn to a character
(setq skipcnt 5
newlst (append newlst (list (atoi (strcat (chr (nth (+ ndx 2) lst))
(chr (nth (+ ndx 3) lst))
(chr (nth (+ ndx 4) lst))
)))))
;; keep the code in the string
(setq skipcnt 5
newlst (append newlst (list 37 37 (nth (+ ndx 2) lst)
(nth (+ ndx 3) lst)
(nth (+ ndx 4) lst)
)))
)
;; else letter code, so fmtcode %%p, %%d, %%c
;; CAB note - this code does not always exist in the string
;; it is used to create the character but the actual ascii code
;; is used in the string, not the case for %%c
(if (vl-position 37 fmt)
(setq skipcnt 3
newlst (append newlst (list (cond ((= (nth (+ ndx 2) lst) "p") 177)
((= (nth (+ ndx 2) lst) "d") 176)
((= (nth (+ ndx 2) lst) "c") 216)
((= (nth (+ ndx 2) lst) "%") 37)
))))
(setq skipcnt 3
newlst (append newlst (list 37 37 (nth (+ ndx 2) lst)
)))
)
) ; endif
) ; endif
) ; endif
) ; end cond (= char "%"))
((= char 92) ; code start with "\"
;; This section processes mtext codes
(cond
;; Process Coded information
((null nextchr) ; true if \ is last char in text
(setq skipcnt 1)
) ; end cond 1
((member nextchr fmtcode) ; this code will end with ";"
;; fmtcode -> ("\C" "\F" "\H" "\T" "\Q" "\W" "\A"))
(while (/= (setq char (nth (+ skipcnt ndx) lst)) 59)
(setq skipcnt (1+ skipcnt))
)
(setq skipcnt (1+ skipcnt))
) ; end cond
;; found \U then get 7 character group
((= nextchr 85) (setq skipcnt (+ skipcnt 7)))
;; found \M then get 8 character group
((= nextchr 77) (setq skipcnt (+ skipcnt 8)))
;; found \P then replace with CR LF 13 10
;; debug do not add CR LF, just remobe \P
((= nextchr 80) ; "\P"
(if (vl-position 80 fmt)
(setq newlst (append newlst '(32))
;ndx (+ ndx 1)
skipcnt 2
)
)
) ; end cond
((= nextchr 123) ; "\{" normal brace
(setq ndx (+ ndx 1))
) ; end cond
((= nextchr 125) ; "\}" normal brace
(setq ndx (+ ndx 1))
) ; end cond
((= nextchr 126) ; "\~" non breaking space
(if (vl-position 126 fmt)
(setq newlst (append newlst '(32)) ; " "
skipcnt 2) ; end cond 9
)
)
;; 2 character group \L \l \O \o
((member nextchr '(76 108 79 111))
(setq skipcnt 2)
) ; end cond
;; Stacked text format as "[ top_txt / bot_txt ]"
((= nextchr 83) ; "\S"
(setq pt (1+ ndx)
tmp '()
)
(while
(not
(member
(setq tmp (nth (setq pt (1+ pt)) lst))
'(94 47 35) ; "^" "/" "#" seperator
)
)
(setq newlst (append newlst (list tmp)))
)
(setq newlst (append newlst '(47))) ; "/"
(while (/= (setq tmp (nth (setq pt (1+ pt)) lst)) 59) ; ";"
(setq newlst (append newlst (list tmp)))
)
(setq ndx pt
skipcnt (1+ skipcnt)
)
) ; end cond
) ; end cond stmt Process Coded information
) ; end cond (or (= char "\\")
) ; end cond stmt
;; Skip format code characters
(if (zerop skipcnt) ; add char to string
(setq newlst (append newlst (list char))
ndx (+ ndx 1)
)
;; else skip some charactersPLOTTABS
(setq ndx (+ ndx skipcnt))
)
) ; end while Loop
) ; end progn
) ; endif
(vl-list->string newlst) ; return the stripped string
) ; end defun
Gruss Nano
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
- 
setq text1 "neu")
