取得多行文本各单行/段落包围框-源码
本帖最后由 wzg356 于 2025-4-25 14:57 编辑;取得多行文本各单行/段落包围框
适用各种对正/左缩进/悬挂
;有缩进/自然换行的炸取配合取得，其他的不用炸取
各单行/段落包围框首/尾/底边也是准确的，框高度是人为设定为1.2倍文字高
本意是放在查找替换工具用http://bbs.mjtd.com/thread-192381-1-1.html
但大篇幅文本效率还是慢，主要是(entupd ent)效率本身
查找替换工具mtext包围框还是采用简单高效的纯炸取法经适当校正使用-http://bbs.mjtd.com/thread-192381-1-1.html
本帖最后由 fangmin723 于 2025-4-25 14:07 编辑
在中望CAD2014中，旋转角度后，右中对齐
添加 (command "none" (car ps))，使多段线闭口
(vl-load-com)
;(setq e(car(entsel)))
;取得多行文本各单行包围框
;有缩进/自然换行的炸取配合取得
(defun Mtextsubboxs (e / ang ang0 boxs czmstr2stri czmstr2text czreplacestr d d0 d1 e1 es exp1 explodedata getmtextbox h hids hids1 mstr ob p01 p02 p03 p04 p1 p11 p12 p2 polarps pos ps putstr2getbox sjd str1 verrot2d)
(progn
(vl-load-com)
;正则表达式字符串替换
;lst: (list(list n1 o1)(list n2 o2))
(defun CZReplacestr (str lst / regex)
(if lst
(progn
(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
(vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配
(foreach x lst
(vlax-put-property regex "Pattern" (cadr x))
(setq str (vlax-invoke-method regex "Replace" str (car x))) ;匹配替换
)
(vlax-release-object regex)
)
)
str
)
;多行文本取得单行字符(类似炸开后取得的结果-自然换行没识别)
(defun CZmstr2text (str / a l2 text1)
(setq str
(CZReplacestr
str
'(("\001" "\\\\\\\\")
("\002" "\\\\{")
("\003" "\\\\}")
("\t" "\\\\p(.[^;]*);")
("$2\t" "\\\\S(\\^|#)(.[^;]*);")
("$1\t" "\\\\S(.[^;]*)(\\^|#);")
("\t" "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);")
("\t" "(\\\\L|\\\\O|\\\\l|\\\\o)")
("\t" "\\\\~")
("\t" "\\\\P")
("\t" "\n")
("\t" "\r")
("\t" "({|})")
("\\" "\\x01")
("{" "\\x02")
("}" "\\x03")
)
)
)
(while (setq a (vl-string-search "\t" str))
(if
(and (> a 0)
(/= "" (vl-string-right-trim " " (setq text1 (substr str 1 a))))
)
(setq l2 (cons text1 l2))
)
(setq str (substr str (+ 2 a)))
)
(if (> (strlen str) 1) (setq l2 (cons str l2)))
(reverse l2)
)
;获取各行单行正文文本及在母文本的位置信息
;(CZmstr2stri mstr(CZmstr2text mstr))
(defun CZmstr2stri (mstr strs / dd flag2 hp hstr i k m n n1 ns ps ps1 str str1)
(setq i 0
k 0
hstr ""
m 0
)
(foreach str strs
(if (listp str)
(setq ps(cadr str)
str (car str)
)
)
;str为lst特殊用法-炸取的子串可获取自然换行
(setq dd (strlen str)
n1 0
m(1+ m)
)
(while (setq n1 (vl-string-search str mstr n1))
(if
(wcmatch (substr mstr 1 n1) ",*[};{],*\\P,*\t,*\r,*\n,*\\L,*\\O,*\\o,*\\~")
(setq nn1
n1 (strlen mstr)
)
(setq n1 (+ dd n1))
)
)
(if n
(progn
(setq str1 (substr mstr 1 n))
(setq mstr (substr mstr (+ 1 dd n)))
(setq i (+ n k i)) ;括号内-k上一次单行长i上次单行位置
(setq k dd)
(if
(or (vl-string-search "\\P" str1)
(vl-string-search "\n" str1)
;下面2项是判断自然换行
(and hp (= i (+ (caar hp) (cadar hp))) (setq flag2 t))
(and ps
ps1
(>
(abs
(car
(trans (mapcar '- (car ps) (car ps1))
0
(mapcar '- (cadr ps1) (car ps1))
)
)
)
(* 1.2 (caddr ps))
)
(setq flag2 t)
)
) ;行首判断
(setq ns (if hp (cons (cons hstr (reverse hp)) ns))
hp (cond
((not ps) (list (list i dd)))
(t
(if flag2
(list (list i dd (car ps) "\n"))
(list (list i dd (car ps)))
)
)
) ;自然换行标记"\n"另用
flag2 nil
hstrstr
)
(setq hp
(if (and ps (= 1 m))
(cons (list i dd (car ps)) hp)
(cons (list i dd) hp)
)
hstr (strcat hstr str)
)
)
(setq ps1 ps)
)
)
)
(reverse (cons (cons hstr (reverse hp)) ns))
)
;炸取MTEXT字串数据
(defun explodedata (e / ang e0 el es h l1 p str)
(setq el (entlast) es (entget e))
(setq ang (cdr (assoc 50 es)))
(vla-Copy (vlax-ename->vla-object e))
((if command-s command-s vl-cmdf) "_explode" (entlast))
(while (setq el (entnext el))
(setq es (entget el))
(setq e0 (cdr (assoc 0 es)))
(if
(and
(= e0 "TEXT")
(/= "" (vl-string-right-trim " " (setq str (cdr (assoc 1 es)))))
)
(setq
p(cdr (assoc 10 es))
h(cdr (assoc 40 es))
l1 (cons (list str (list p (polar p ang (* 10 h)) h)) l1)
)
)
(entdel el)
)
(reverse l1)
)
(defun getMtextbox (e / a es l l1 p1 p2 w w1 z)
(setq
es (entget e)
a(cdr (assoc 50 es))
l(cdr (assoc 42 es))
w(cdr (assoc 43 es))
z(cdr (assoc 71 es))
w1 (if (member z '(4 5 6)) (* 0.5 w) (if (member z '(7 8 9)) 0 w))
l1 (if (member z '(2 5 8)) (* 0.5 l) (if (member z '(1 4 7)) 0 l))
p1 (polar (polar (verRot2D (cdr (assoc 10 es)) (- 0 a)) pi l1)
(* 1.5 pi)
w1
)
p1 (verRot2D p1 a)
p2 (polar p1 a l)
a(+ a (* 0.5 pi))
)
(list p1 p2 (polar p2 a w) (polar p1 a w))
)
(defun verRot2D (v a / c s x y)
(setq
c (cos a)
s (sin a)
x (car v)
y (cadr v)
)
(list (- (* x c) (* y s)) (+ (* x s) (* y c)))
);;; 旋转向量到指定角度 by高飞
(defun polarps (ps ang d)
(mapcar (function (lambda (p) (polar p ang d))) ps)
) ;点集按向移位
(defun putstr2getbox (e str)
(Vlax-Put (vlax-ename->vla-object e) 'TextString str)
(entupd e)
(setq ps (getMtextbox e))
)
)
(setq ob (vlax-ename->vla-object e))
(setq es (entget e))
(setq pos (cdr (assoc 71 es)))
(setq mstr (Vlax-Get ob 'TextString))
(setq ps (getMtextbox e))
(setq p01 (car ps)
p02 (cadr ps)
p03 (caddr ps)
p04 (cadddr ps)
)
(setq d0 (cdr (assoc 41 es)))
(setq h (* 1.35 (cdr (assoc 40 es))))
(if
(and
(or (= 0 d0) (> d0 (+ h (distance p01 p02))))
;+h是确保无自然换行
(not (wcmatch mstr "*\\pxi#*,*\\pxi-#*,*\\pi#*,*\\pi-#*")) ;无缩进
)
(setq hids (reverse (CZmstr2stri mstr (CZmstr2text mstr))))
;可以不炸取的情况
(setq hids (reverse (CZmstr2stri mstr (explodedata e))))
;有自然换行或缩进,炸取单行文本也是高效的
)
(setq d0 (distance p01 p04))
(setq ang0 (cdr (assoc 50 es))
ang(+ (* 0.5 pi) ang0)
)
(setq hids1 hids)
(foreach id hids
(vla-Copy (vlax-ename->vla-object e))
(setq e1 (entlast))
;复制可减少最后一次(entupd e)效率近乎倍增
(setq str1 mstr)
(setq str1 (substr str1 1 (+ (car (last id)) (cadr (last id)))))
;删除该行以后--不影响格式
(if (cadddr (cadr id))
(setq str1 (strcat
(substr str1 1 (caadr id))
"\n"
(substr str1 (1+ (caadr id)))
)
)
) ;炸取数据有自然换行l临时加入换行符-取包围框
(if (setq p1 (caddr (cadr id)))
(setq sjd (car (trans (mapcar '- p1 p04) 0 (mapcar '- p01 p04))))
(setq sjd 0)
) ;炸取数据取得的行首基点-计算缩进
(setq ps (putstr2getbox e1 str1))
(if (member pos '(7 8 9))
(setq p1 (cadddr ps)
p2 (caddr ps)
)
(setq p1 (car ps)
p2 (cadr ps)
d1 (distance (car ps) (cadddr ps))
)
) ;比对基线点
(foreach subid (setq hids1 (cdr hids1))
(foreach a (reverse (cdr subid))
(setq str1 (strcat
(substr str1 1 (car a))
(substr str1 (+ 1 (car a) (cadr a)))
)
)
) ;改行以前有效字符全换为""
)
(setq ps (putstr2getbox e1 str1))
(entdel e1)
(setq p11 (car ps)
p12 (cadr ps)
) ;比对基线点
(setq exp1 '(list p11 p12 (polar p12 ang h) (polar p11 ang h)))
(if (member pos '(7 8 9))
(setq ps (eval exp1)
d(car (trans (mapcar '- (caddr ps) p1) 0 (mapcar '- p2 p1)))
ps (polarps ps ang (+ d d0 (- 0 h)))
)
(setq d (car (trans (mapcar '- p11 p2) 0 (mapcar '- p1 p2)))
p11 (polar p11 ang d)
p12 (polar p12 ang d)
ps(eval exp1)
ps(if (member pos '(1 2 3))
ps
(polarps ps ang (* 0.5 (- d0 d1)))
)
)
)
(setq ps (polarps ps ang0 sjd))
(setq boxs (cons (list (caadr id) (strlen (car id)) ps) boxs))
;(setq boxs(cons ps boxs))
)
boxs
)
;测试
(defun c:tt66 (/ e)
(if (setq e (ssget ":s:e" '((0 . "mtext"))))
(foreach ps (mapcar 'caddr (Mtextsubboxs (ssname e 0)))
(command "pline")
(foreach p ps (command "none" p))
(command "none" (car ps))
(command "")
)
)
)
本帖最后由 wzg356 于 2025-4-25 14:34 编辑
fangmin723 发表于 2025-4-25 14:14
后面的数字都忽略了吗，还有，试着更改多行文子的行高或行高比例，你那边可以测试下看看，有没有问题
有效文字没问题的，包围框首尾也没问题——/与字高行高无关——是CAD系统的包围框数据几何比对计算获取。
炸开仅仅是为了快速确定自然换行的字符位置（不是坐标） fangmin723 发表于 2025-4-25 14:14
后面的数字都忽略了吗，还有，试着更改多行文子的行高或行高比例，你那边可以测试下看看，有没有问题
取得各单行/段落内容和位置索引hids
mstr是完整的带格式的多行文本字符串
(setq hids(reverse(CZmstr2stri mstr(CZmstr2text mstr)))) fangmin723 发表于 2025-4-25 14:06
在中望CAD2014中，旋转角度后，右中对齐
我没用中望，CAD包围框中望不支持 本帖最后由 fangmin723 于 2025-4-25 14:19 编辑
wzg356 发表于 2025-4-25 14:12
我没用中望，CAD包围框中望不支持
后面的数字都忽略了吗，还有，试着更改多行文子的行高或行高比例，你那边可以测试下看看，有没有问题 wzg356 发表于 2025-4-25 14:34
取得各单行/段落内容和位置索引hids
mstr是完整的带格式的多行文本字符串
(setq hids(reverse(CZmstr2s ...
等有时间了，我研究下，看看中望哪里出了问题 刚刚还在想代码，准备看有没有现成的，马上这就有了，及时雨啊 支持，感谢分享
适合简单的Mtext格式
页:
[1]
2