分解MTEXT（源码）-非炸开之重写方式

尘缘一生

一直头疼图纸说明，MTEXT文字各段压落问题，
分解MTEXT方法呢，会造成关联其他程序中断，采取重写方式成文，是个好办法
然而，对于重写方式，一直有不好解决的问题，特别是，对于重写一行到底取多少数呢？
考虑从MTEXT的框子宽度，取得这个值，也没想起来怎么取，可能本来MTEXT里就有，这个最大字数的内码在，
发下，谁能给出这个值的取法吗？

• ;;重写方式分解MTEXT
• ;;by 尘缘一生 QQ：15290049
• (defun c:tt ()
•   (setq nam (car (entsel)))
•   (setq  
•     col (ss-getcolor nam) ;;颜色
•     hi (e-higt nam) ;;高度
•     ang (e-ang nam nil)
•     p0 (polar (dxf1 nam 10) (- ang pi2) (* 1.5 hi))
•     ;;p0 (car (e-box4 enam nil)) ;;垂直文字BUG
•   )
•   (if (null (setq ly (dxf1 nam 8))) (setq ly (getvar "clayer")))
•   (if (null (setq sty (dxf1 nam 7))) (setq sty $hz))
•   (setq lis (reverse (str->lst (t-string-subst "\\" "\\P" (mtext2text nam)) "\\")))
• ;(entdel nam) ；测试先注销，发布需要
•   (repeat (setq j (length lis))
•     (setq str (nth (setq j (1- j)) lis))
•     (setq lis1 (reverse (xl-div (sl-str->singleonly str) 46))) ;此处46，为裂解重写一行字数，需要深入研究，如何从MTEXT里，取得这个变值为妙
•     (repeat (setq n (length lis1))
•       (setq lis0 (nth (setq n (1- n)) lis1) str0 "")
•       (repeat (setq i (length lis0))
•         (setq str0 (strcat (nth (setq i (1- i)) lis0) str0))
•       )
•       (entmake (list '(0 . "TEXT") (cons 1 str0) (cons 8 ly) (cons 62 col) (cons 7 sty) (cons 10 p0) (cons 40 hi) (cons 50 ang) (cons 41 0.7)))
•       (setq p0 (polar p0 (- ang pi2) (* 1.5 hi)))
•     )
•   )
• )
• ;提取多行文字,去除无用格式符号,但保留分行符\\P-----(一级)------
• ;返回-->  "4.钢筋的连接要求\\P 钢筋直径d>20mm时，用机..."
• (defun mtext2text (nam / s ob) ;; (setq s (vlax-get (en2obj (car (entsel))) 'TextString))
•   (setq s (vlax-get (en2obj nam) 'TextString))
•   (vlax-put-property (setq ob (vlax-create-object "Vbscript.RegExp")) "IgnoreCase" 0)
•   (vlax-put-property ob "Global" 1)
•   (setq s
•     (mapcar
•       '(lambda (x y) (vlax-put-property ob "Pattern" x) (setq s (vlax-invoke-method ob "Replace" s y)))
•       '("\\\\\\\\" "\\\\{" "\\\\}" "\\\\p(.[^;]*);" "\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);"
•          "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);" "(\\\\L|\\\\O|\\\\l|\\\\o)" "\\\\~"
•          "({|})" "\\x01" "\\x02" "\\x03")
•       (list (chr 1) (chr 2) (chr 3) "" "" "" "" "" (chr 0) "" "" "\\" "{" "}")
•     )
•   )
•   (if ob (vlax-release-object ob))
•   (last s)
• )
• ;;字符串以旧换新----(一级)----
• ;;(t-string-subst "毛" "a" "abc")
• (defun t-string-subst (new old str / n)
•   (setq n (- (strlen new)))
•   (while (setq n (vl-string-search old str (min (+ n (strlen new)) (strlen str))))
•     (setq str (vl-string-subst new old str n))
•   )
•   str
• )
• ;;字符串转表 str 字符串   sign 分割符号----(一级)---------
• ;;(str->lst "1 2 3 4" " ")->("1" "2" "3" "4")
• ;;(str->lst "毛泽东;88;xy;z" ";")->("毛泽东" "88" "xy" "z")
• ;;(str->lst "毛泽东;88;xy;z" "泽东")->("毛" ";88;xy;z")
• (defun str->lst (str sign / lst n1 n2 str_1 m2)
•   (setq lst '())
•   (setq n1 (strlen str))
•   (setq n2 (strlen sign))
•   (while (setq m2 (vl-string-search sign str))
•     (setq str_1 (substr str 1 m2))
•     (setq str (substr str (+ 1 m2 n2)))
•     (if (/= str_1 "")
•       (setq lst (cons str_1 lst))
•     )
•   )
•   (if (/= str "")
•     (setq lst (cons str lst))
•   )
•   (reverse lst)
• )
• ;;字符串转表 中英文拆分为单独文字表-----(一级)------
• ;;(sl-str->singleonly "12我 的\n毛泽东")  ("1" "2" "我" " " "的" "\n" "毛" "泽" "东")
• (defun sl-str->singleonly (str / strlst strlst1 hz_str)
•   (setq  strlst (vl-string->list str) strlst1 '())
•   (while strlst
•     (cond
•       ((and (not hz_str)
•          (> (car strlst) 159)
•        )
•         (setq hz_str (list (car strlst)))
•         (setq strlst (cdr strlst))
•       )
•       ((and hz_str
•          (> (car strlst) 159)
•        )
•         (setq hz_str (append hz_str (list (car strlst))))
•         (setq strlst (cdr strlst))
•         (setq strlst1 (append strlst1 (list hz_str)) hz_str nil)
•       )
•       ((< (car strlst) 159)
•         (setq hz_str nil)
•         (if strlst1
•           (setq strlst1 (append strlst1 (list (list (car strlst)))))
•           (setq strlst1 (list (list (car strlst))))
•         )
•         (setq strlst (cdr strlst))
•       )
•     )
•   )
•   (mapcar 'vl-list->string strlst1)
• )
• ;;表分组----(一级)----              
• ;(setq lst'(1 2 3 4 5 6 7 8 9 10 11 12 13))              
• ;(xl-div lst 3)返回((1 2 3)(4 5 6)(7 8 9)(10 11 12) (13))
• (defun xl-div (lst n / i rtn)
•   (while lst
•     (repeat (min n (length lst))
•       (setq i (cons (car lst) i) lst (cdr lst))
•     )
•     (setq rtn (cons (reverse i) rtn) i nil)
•   )
•   (reverse rtn)
• )
  

尘缘一生

想起来一个办法，贴上，用于比较：

• ;;重写方式分解MTEXT
• ;;by 尘缘一生 QQ：15290049
• (defun c:tt (/ nam col hi ang p0 ly sty num0 num j n i lis lis1 lis0 str str0)
•   (setq nam (car (entsel)))
•   (setq  
•     col (ss-getcolor nam) ;;颜色
•     hi (e-higt nam) ;;高度
•     ang (e-ang nam nil)
•     p0 (polar (dxf1 nam 10) (- ang pi2) (* 1.5 hi))
•     ;;p0 (car (e-box4 enam nil)) ;;垂直文字BUG,舍弃包容盒办法
•   )
•   (if (null (setq ly (dxf1 nam 8))) (setq ly (getvar "clayer")))
•   (if (null (setq sty (dxf1 nam 7))) (setq sty $hz)) ;$hz 全局变量，STYLE
•   
•   (setq lis (reverse (str->lst (t-string-subst "\\" "\\P" (mtext2text nam)) "\\")) num0 1)
• ;(entdel nam) ；测试先注销，发布需要
•   (repeat (setq j (length lis)) ;取得最大每行写多少字
•     (setq num (numstr (nth (setq j (1- j)) lis))) ;(strlen "毛") 2
•     (if (<= num num0) (setq num num0))
•     (setq num0 num)
•   )
•   (repeat (setq j (length lis))
•     (setq str (nth (setq j (1- j)) lis))
•     (setq lis1 (reverse (xl-div (sl-str->singleonly str) num)))
•     (repeat (setq n (length lis1))
•       (setq lis0 (nth (setq n (1- n)) lis1) str0 "")
•       (repeat (setq i (length lis0))
•         (setq str0 (strcat (nth (setq i (1- i)) lis0) str0))
•       )
•       (entmake (list '(0 . "TEXT") (cons 1 str0) (cons 8 ly) (cons 62 col) (cons 7 sty) (cons 10 p0) (cons 40 hi) (cons 50 ang) (cons 41 0.7)))
•       (setq p0 (polar p0 (- ang pi2) (* 1.5 hi)))
•     )
•   )
• )
• ;;字符文字串逻辑长度值-----(一级)-----
• (defun numstr (str / ns lis n num1)
•   (setq ns 0 lis (sl-str->singleonly str))
•   (repeat (setq n (length lis))
•     (setq num1 (nth (setq n (1- n)) lis))
•     (cond
•       ((or (< (ascii num1) 97) (and (> (ascii num1) 122) (<= (ascii num1) 128)))
•         (setq ns (1+ ns))
•       )
•       ((and (>= (ascii num1) 97) (< (ascii num1) 122)) ;小写英文字母
•         (setq ns (1+ ns))
•       )
•       ((> (ascii num1) 128) ;;汉字
•         (setq ns (+ ns 2))
•       )
•     )
•   )
•   ns
• )
  

备注下：这段代码，测试失败，不行，不可用

xq4u

沙发，新年刚过就发帖了，楼主实在是敬业啊

ju5027

no function definition: SSGETCOLOR

hzyhzjjzh

谢谢楼主分享

尘缘一生

ju5027 发表于 2023-1-28 11:27
no function definition: SSGETCOLOR

这些看字面不很明白吗，有些涉及集成，实际很简单，集成的并不是特意为之，实际是，兼容性问题，那些函数只不过是确保不同实体的正确性，对于MTEXT来说，可以如此处理。。。

• ;;重写方式分解炸开MTEXT----(一级)------
• ;;ss 返回炸开后TEXT选择集
• (defun expmtext (nam / col hi ang p0 ly sty j n i lis lis1 lis0 str str0 ss)
•   (setq  
•     ss (ssadd)
•     col (dxf1 nam 62) ;;颜色
•     hi (dxf1 nam 40) ;;高度
•     ang (dxf1 nam 50) ;锐角弧度
•   )
•   (setq p0 (cadddr (e-box4 nam t))) ;取包容盒左上角
•   (if (null (setq ly (dxf1 nam 8))) (setq ly (getvar "clayer")))
•   (if (null (setq sty (dxf1 nam 7))) (setq sty $hz))  
•   (setq lis (reverse (str->lst (t-string-subst "\\" "\\P" (gets-mt-p nam)) "\\")))
•   (entdel nam)
•   (repeat (setq j (length lis))
•     (setq str (nth (setq j (1- j)) lis))
•     (setq lis1 (reverse (xl-div (sl-str->singleonly str) 56)))
•     (repeat (setq n (length lis1))
•       (setq lis0 (nth (setq n (1- n)) lis1) str0 "")
•       (repeat (setq i (length lis0))
•         (setq str0 (strcat (nth (setq i (1- i)) lis0) str0))
•       )
•       (entmake ;左上定位文字
•         (list '(0 . "TEXT") (cons 1 str0) (cons 8 ly) (cons 62 col) (cons 7 sty) (cons 10 (polar p0 (- ang pi2) hi)) (cons 40 hi)
•           (cons 72 0) (cons 11 p0) (cons 73 3)(cons 50 ang) (cons 41 0.7)
•         )
•       )
•       (entmod (emod (emod (entget (entlast)) 72 0) 73 0)) ;转左下定位,按需
•       (ssadd (entlast) ss)
•       (setq p0 (polar p0 (- ang pi2) (* 1.5 hi)))
•     )
•   )
•   ss
• )
  

• ;取得图元参数值内容-----(一级)-------
• ;;(setq h (dxf1 ent 40))
• ; ent 为实体名或实体entget，
• (defun dxf1 (ent i / tmp)
•   (if (= (type ent) 'ENAME)
•     (setq ent (entget ent '("*")))
•   )
•   (setq tmp (cdr (assoc i ent)))
•   (if (null tmp)
•     (cond
•       ((= i 66) 0)
•       ((= i 48) (getvar "celtscale"))
•       ((= i 62) 256)
•       ((= i 370) (setq tmp -1))
•       ((= i 6) "ByLayer")
•     )
•     tmp  
•   )
  

vladimir

非常不错的代码，谢谢楼主分享啊。