文字刷-2021.11更新 刷相同文字 支持块中文字、单多行文字、天正文字
本帖最后由 print1985 于 2021-11-22 17:22 编辑参考各位大神的代码，做了个文本内容刷-刷相同文字
支持块中文字（块中文字只能点选，其它文字可以框选）、单行文字、多行文字、天正文字、天正图名、天正标高、属性文字、块中属性文字。
因为没人帮忙测试，如发现bug请反馈。
更多功能以后再慢慢添加。
更新记录：
V3.2 2021.11 增加天正标注、CAD多重引注（都是源码，需要支持更多类型，自己改改就行）
V3.0 2016.04 多行文字刷单行文字时，去除多行文字无用格式符号；增加亮显、错误处理及其它地方小改。
V2.1 修正用户坐标系时，无法点选刷字的bug
V2.0 增加了对属性文字、块中属性文字的支持
阿甘大师好
在天正T20 v7与CAD2022的软件搭配环境下测试了
从“天正图元”刷到“CAD图元”
1.天正图元（标高标注、图名标注）> CAD图元（文字、多行文字、块内文字），完美可行。
然后把条件反转一下
从“CAD图元”刷到“天正图元”
2.CAD图元（文字、多行文字、块内文字）> 天正图元（标高标注、图名标注），不能刷成功。 刷标注的时候可以正常刷，但是对象只要移动位置标注文字就会变回去，查看标注的文字替代是空的。关键是这个现象有时候出现有时候又没事，不知道啥原因。 kucha007 发表于 2021-4-20 14:42
附议。这个功能真的很需要。改物料的时候简直崩溃
感谢大大的回复，受教了。不过确实也是因为自己不会改才会请求完善代码:lol 好东东。 谢谢分享。 源码顶下 非常好的程序，要是能再加上文本内容对换就完美了。。。
下面这个是Lee-mac的文本刷，不过不支持天正文字。。。
;**************文本内容刷/对换
(defun c:2 nil (CopyorSwapText nil))
(defun c:22 nil (CopyorSwapText t))
(defun CopyorSwapText
(swap / *error* _StartUndo
_EndUndo _UnFormat _AllowsFormatting
doc entity ms1 ms2
mstr o1 o2 ostr
regexp ss string ts1
ts2 tstr
)
(vl-load-com)
(setq *retain* (cond (*retain*)
("Yes")
)
)
;;------------------------------------------------------------;;
;; Local Functions ;;
;;------------------------------------------------------------;;
(defun *error* (msg)
(LM:ReleaseObject RegExp)
(if doc
(_EndUndo doc)
)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
;;------------------------------------------------------------;;
(defun _StartUndo (doc)
(_EndUndo doc)
(vla-StartUndoMark doc)
)
;;------------------------------------------------------------;;
(defun _EndUndo (doc)
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
;;------------------------------------------------------------;;
(defun _UnFormat
(regex entity textstring mtextstring / *error* _Replace)
(defun _Replace (new old string)
(vlax-put-property regex 'pattern old)
(vlax-invoke regex 'replace string new)
)
(
(lambda (string)
(if (_AllowsFormatting entity)
(mapcar
(function
(lambda (x)
(setq string (_Replace (car x) (cdr x) string))
)
)
'(
("" . "\\\\\\\\")
(" " . "\\\\P|\\n|\\t")
("$1"
.
"\\\\(\\\\)|\\\\[^\\\\;]*;|\\\\"
)
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{")
)
)
(setq string
(_Replace "" "%%" (_Replace "" "\\\\" string))
)
)
(set mtextstring
(_Replace "\\\\"
""
(_Replace "\\$1$2$3"
"(\\\\)|({)|(})"
string
)
)
)
(set textstring (_Replace "\\" "" string))
)
(LM:GetTextString entity)
)
nil
)
;;------------------------------------------------------------;;
(defun _Selectif (pred func str keyW / e result)
(while
(progn (setvar 'ERRNO 0)
(if keyW
(initget keyW)
)
(setq e (func str))
(cond
((= 7 (getvar 'ERRNO))
(princ "\n** 未选择, 请重新选择对象 **")
)
((and keyW (eq 'STR (type e)))
(not (setq result e))
)
((vl-consp e)
(if (and pred (not (pred (car e))))
(princ "\n** 无效的物体被选择 **")
(not (setq result (car e)))
)
)
)
)
)
result
)
;;------------------------------------------------------------;;
(defun _AllowsFormatting (entity / object)
(or (wcmatch (cdr (assoc 0 (entget entity)))
"MTEXT,MULTILEADER"
)
(and
(eq "ATTRIB" (cdr (assoc 0 (entget entity))))
(vlax-property-available-p
(setq object (vlax-ename->vla-object entity))
'MTextAttribute
)
(eq :vlax-true (vla-get-MTextAttribute object))
)
)
)
;;------------------------------------------------------------;;
;; Main Function ;;
;;------------------------------------------------------------;;
(setq RegExp (vlax-get-or-create-object "VBScript.RegExp"))
(mapcar
(function
(lambda (x) (vlax-put-property RegExp (car x) (cdr x)))
)
(list (cons 'global actrue)
(cons 'ignorecase acfalse)
(cons 'multiline actrue)
)
)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(cond
(
swap
(while
(and
(progn
(while
(and (princ (strcat "\n--> Formatting Retained: " *retain*))
(setq o1
(_Selectif
(lambda (entity)
(wcmatch (cdr (assoc 0 (entget entity)))
"*TEXT,ATTRIB,MULTILEADER"
)
)
nentsel
"\nSelect Text to Swap <Exit>: "
"Settings Exit"
)
)
(eq 'STR (type o1))
(not (eq "Exit" o1))
)
(initget "Yes No")
(setq *retain*
(cond
(
(getkword
(strcat "\nRetain MText Formatting <"
*retain*
"> : "
)
)
)
(*retain*)
)
)
)
o1
)
(setq o2
(_Selectif
(lambda (entity)
(wcmatch (cdr (assoc 0 (entget entity)))
"*TEXT,ATTRIB,MULTILEADER"
)
)
nentsel
"\nAnd Text to Swap it With <Exit>: "
"Exit"
)
)
(not (eq "Exit" o2))
)
(_StartUndo doc)
(setq s1 (LM:GetTextString o1)
s2 (LM:GetTextString o2)
)
(_Unformat RegExp o1 'ts1 'ms1)
(_Unformat RegExp o2 'ts2 'ms2)
(apply
(function
(lambda (retain MText1 MText2)
(setq o1 (vlax-ename->vla-object o1)
o2 (vlax-ename->vla-object o2)
)
(cond
(
(and MText1 MText2)
(vla-Put-TextString
o1
(if retain
s2
ms2
)
)
(vla-Put-TextString
o2
(if retain
s1
ms1
)
)
)
(
MText1
(vla-Put-TextString o1 ms2)
(vla-Put-TextString o2 ts1)
)
(
MText2
(vla-Put-TextString o1 ts2)
(vla-Put-TextString o2 ms1)
)
(
t
(vla-Put-TextString
o1
(if retain
s2
ts2
)
)
(vla-Put-TextString
o2
(if retain
s1
ts1
)
)
)
)
)
)
(cons (eq "Yes" *retain*)
(mapcar '_AllowsFormatting (list o1 o2))
)
)
(_EndUndo doc)
)
)
(t
(if
(progn
(while
(and (princ (strcat "\n--> Formatting Retained: " *retain*))
(setq o1
(_Selectif
(lambda (entity)
(wcmatch (cdr (assoc 0 (entget entity)))
"*TEXT,ATTRIB,MULTILEADER"
)
)
nentsel
"\nSelect Source Object <Exit>: "
"Settings Exit"
)
)
(eq 'STR (type o1))
(not (eq "Exit" o1))
)
(initget "Yes No")
(setq *retain*
(cond
(
(getkword
(strcat "\nRetain MText Formatting <"
*retain*
"> : "
)
)
)
(*retain*)
)
)
)
o1
)
(progn
(setq ostr (LM:GetTextString o1))
(_Unformat RegExp o1 'tstr 'mstr)
(if (eq "Yes" *retain*)
(set (if (_AllowsFormatting o1)
'mstr
'tstr
)
ostr
)
)
(_StartUndo doc)
(terpri)
(while
(and
(setq o2
(_Selectif
(lambda (entity)
(wcmatch (cdr (assoc 0 (entget entity)))
"*TEXT,ATTRIB,MULTILEADER"
)
)
nentsel
"\rSelect Destination Object [多个<M>/Exit] <Exit>: "
"Multiple Exit"
)
)
(not (eq "Exit" o2))
)
(cond
(
(eq "Multiple" o2)
(if
(setq ss
(ssget "_:L"
'(
(-4 . "<OR")
(0 . "TEXT,MTEXT,MULTILEADER")
(-4 . "<AND")
(0 . "INSERT")
(66 . 1)
(-4 . "AND>")
(-4 . "OR>")
)
)
)
(
(lambda (i / _type e)
(while (setq e (ssname ss (setq i (1+ i))))
(cond
(
(eq "INSERT"
(setq _type (cdr (assoc 0 (entget e))))
)
(mapcar
(function
(lambda (attrib)
(vla-put-TextString
attrib
(if
(and
(vlax-property-available-p
attrib
'MTextAttribute
)
(eq :vlax-true
(vla-get-MTextAttribute attrib)
)
)
mstr
tstr
)
)
)
)
(vlax-invoke
(vlax-ename->vla-object e)
'GetAttributes
)
)
)
(t
(vla-put-TextString
(vlax-ename->vla-object e)
(if (_AllowsFormatting e)
mstr
tstr
)
)
)
)
)
)
-1
)
)
t
)
((vla-put-TextString
(vlax-ename->vla-object o2)
(if (_AllowsFormatting o2)
mstr
tstr
)
)
)
)
)
(_EndUndo doc)
)
)
)
)
(LM:ReleaseObject RegExp)
(princ)
)
;;--------------------=={ Get TextString }==------------------;;
(defun LM:GetTextString (object)
;;Lee Mac 2010
(
(lambda (entity / _type elist)
(cond
(
(wcmatch
(setq _type
(cdr
(assoc 0
(setq elist
(entget entity)
)
)
)
)
"TEXT,*DIMENSION"
)
(cdr (assoc 1 elist))
)
(
(eq "MULTILEADER" _type)
(cdr (assoc 304 elist))
)
(
(wcmatch _type "ATTRIB,MTEXT")
(
(lambda (string)
(mapcar
(function
(lambda (pair)
(if (member (car pair) '(1 3))
(setq string (strcat string (cdr pair)))
)
)
)
elist
)
string
)
""
)
)
)
)
(if (eq 'VLA-OBJECT (type object))
(vlax-vla-object->ename object)
object
)
)
)
;;------------------=={ Release Object }==--------------------;;
(defun LM:ReleaseObject (obj)
(vl-load-com)
;;Lee Mac 2010
(and obj
(eq 'VLA-OBJECT (type obj))
(not (vlax-object-released-p obj))
(not
(vl-catch-all-error-p
(vl-catch-all-apply
(function vlax-release-object)
(list obj)
)
)
)
)
)
(princ)
支持天正文字,这个不错 谢谢分享源码。 谢谢分享。
谢谢楼主的分享！
等会试试。
谢谢！ ㄘ丶转裑ㄧ灬 发表于 2012-9-7 18:45 static/image/common/back.gif
非常好的程序，要是能再加上文本内容对换就完美了。。。
下面这个是Lee-mac的文本刷，不过不支持天正文字。 ...
谢谢楼上的源码分享！
等会试试。
谢谢！