分解MTEXT（源码）-非炸开之重写方式
本帖最后由 尘缘一生 于 2023-1-28 01:27 编辑一直头疼图纸说明，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)
[*](setqstrlst (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)
[*])
本帖最后由 尘缘一生 于 2023-1-28 18:41 编辑
想起来一个办法，贴上，用于比较：
[*];;重写方式分解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
[*])
备注下：这段代码，测试失败，不行，不可用
沙发，新年刚过就发帖了，楼主实在是敬业啊 no function definition: SSGETCOLOR 谢谢楼主分享 本帖最后由 尘缘一生 于 2023-1-28 18:50 编辑
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
[*])
非常不错的代码，谢谢楼主分享啊。
页:
[1]