文字刷-改进使用要求
制图中经常要修改 索引号中的文字，例如 A.B.C，1.2....， 图号，反索引图号，这是重复性劳动，我希望能用以下的程序改进一下我的目的，ct 命令，能改进一下Gu_xl的程序，可随意抓取属性块，其中某个文字，把文字内容copy到粘贴板中
wt 命令，能像文本刷第2个操作步骤，点选属性块其中某个文字，就把那个文字替换成粘贴板的内容，能连续点选，直到空选结束
希望有能力的人伸出缓手，感谢！
;;; -------------------------------------------------------------------------
引用 文字刷.原程序http://bbs.mjtd.com/thread-96376-1-1.html
;;; -------------------------------------------------------------------------
;;; 文本内容刷V3.0命令fa --by 阿甘 2016.04
;;; 支持块中文字（块中文字只能点选，其它文字可以框选）、单行文字、多行文字、天正文字、天正图名、天正标高、属性文字、块中属性文字
(vl-load-com)
(setq source_text nil) ; 设源文字为全局变量
(defun c:fa (/ en en_data en1 en1_data ent entype entype_source i ob pt ss ss_data txtst *error* x)
(defun *error* (x) ;出错函数
(if en (redraw (car en) 4))
(setvar "ErrNo" 0)
(setvar "cmdecho" 1)
)
(setvar "cmdecho" 0)
(setvar "ErrNo" 0)
(if (= source_text nil)
(if (setq en (nentsel "\n请选择源文字(右键退出):"))
(progn
(setq en_data (entget (car en)))
(setq entype_source (cdr (assoc 0 en_data)))
(if (or (setq txtst (cdr (assoc 7 en_data))) (= entype_source "TCH_DRAWINGNAME"))
(progn
(redraw (car en) 3)
(if (= entype_source "ATTDEF") ;如果是属性字，则取“标记”为源文字
(setq source_text (cdr (assoc 2 en_data)))
(setq source_text (cdr (assoc 1 en_data)))
)
))
)
)
(if (and (= (setq en (nentsel (strcat "\n请选择源文字: 默认:" source_text))) nil) (= (getvar "ErrNo") 52))
(progn
(setvar "ErrNo" 0)
(setq txtst T)
)
(if en
(progn
(setq en_data (entget (car en)))
(setq entype_source (cdr (assoc 0 en_data)))
(if (or (setq txtst (cdr (assoc 7 en_data))) (= entype_source "TCH_DRAWINGNAME"))
(progn
(redraw (car en) 3)
(if (= entype_source "ATTDEF") ;如果是属性字，则取“标记”为源文字
(setq source_text (cdr (assoc 2 en_data)))
(setq source_text (cdr (assoc 1 en_data)))
)
))
)
(setvar "ErrNo" 52)
)
)
)
(if (or txtst (= entype_source "TCH_DRAWINGNAME"))
(progn
(prompt "\n请选择要修改内容的文字:")
(while (/= (getvar "ErrNo") 52)
(prompt (strcat "\n文字内容将被刷成:" source_text))
(if (and (setq ss (ssget ":S" '((0 . "*TEXT,TCH_DRAWINGNAME,TCH_ELEVATION,INSERT,ATTDEF,ATTRIB")))) source_text)
(progn
(if (= (caar (setq ss_data (ssnamex ss 0))) 1)
(progn ; 点选时
(setq ent (ssname ss 0)
pt (trans (cadr (last (car ss_data))) 0 1)
en1 (car (nentselp pt))
en1_data (entget en1)
entype (cdr (assoc 0 en1_data))
ob (vlax-ename->vla-object en1)
)
(wenzishua entype entype_source ob source_text en1 ent)
)
(progn ; 框选时
(setq i 0)
(repeat (sslength ss)
(setq en1 (ssname ss i)
ent en1
en1_data (entget en1)
entype (cdr (assoc 0 en1_data))
ob (vlax-ename->vla-object en1)
)
(wenzishua entype entype_source ob source_text en1 ent)
(setq i (1+ i))
) ; end repeat
)
)
)
)
); end while
))
(if en (redraw (car en) 4))
(setvar "ErrNo" 0)
(setvar "cmdecho" 1)
(princ)
)
;文字刷子程序
(defun wenzishua (entype entype_source ob source_text en1 ent)
; cad多行文字
(if (= entype "MTEXT")
(progn
(vla-put-TextString ob source_text)
(entupd en1)
(entupd ent)
)
)
;去掉多行文字无用格式符号
(if (= entype_source "MTEXT")
(setq source_text (mtext2text source_text))
)
; cad单行文字
(if (= entype "TEXT")
(progn
(vla-put-TextString ob source_text)
(entupd en1)
(entupd ent)
)
)
; 天正文字的内容格式刷
(if (or
(= entype "TCH_TEXT")
(= entype "TCH_ELEVATION")
)
(progn
(vlax-put-property ob 'Text source_text)
(entupd en1)
(entupd ent)
)
)
; 天正图名、标高的内容格式刷
(if (= entype "TCH_DRAWINGNAME")
(progn
(vlax-put-property ob 'NameText source_text)
(entupd en1)
(entupd ent)
)
)
; 属性文字 只改"标记"
(if (= entype "ATTDEF")
(progn
(vla-put-TagString ob source_text);改标记
(entupd en1)
(entupd ent)
)
)
; 块中属性文字 只改"默认"
(if (= entype "ATTRIB")
(progn
(vla-put-TextString ob source_text);改默认
(entupd en1)
(entupd ent)
)
)
)
;提取多行文字,去除无用格式符号--来自明经
(defun mtext2text(MTextString / regex s)
(setq regex(vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
(vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配
(setq s MTextString)
;替换\\字符
(vlax-put-property regex "Pattern" "\\\\\\\\")
(setq s(vlax-invoke-methodregex "Replace" s (chr 1)))
;替换\{字符
(vlax-put-property regex "Pattern" "\\\\{")
(setq s(vlax-invoke-methodregex "Replace" s (chr 2)))
;替换\}字符
(vlax-put-property regex "Pattern" "\\\\}")
(setq s(vlax-invoke-methodregex "Replace" s (chr 3)))
;删除段落缩进格式
(vlax-put-property regex "Pattern" "\\\\pi(.[^;]*);")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除制表符格式
(vlax-put-property regex "Pattern" "\\\\pt(.[^;]*);")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除堆迭格式
(vlax-put-property regex "Pattern" "\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
(vlax-put-property regex "Pattern" "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除下划线、删除线格式
(vlax-put-property regex "Pattern" "(\\\\L|\\\\O|\\\\l|\\\\o)")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除不间断空格格式
(vlax-put-property regex "Pattern" "\\\\~")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除换行符格式
(vlax-put-property regex "Pattern" "\\\\P")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除换行符格式(针对Shift+Enter格式)
(vlax-put-property regex "Pattern" "\n")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;删除{}
(vlax-put-property regex "Pattern" "({|})")
(setq s(vlax-invoke-methodregex "Replace" s ""))
;替换回\\,\{,\}字符
(vlax-put-property regex "Pattern" "\\x01")
(setq s(vlax-invoke-methodregex "Replace" s "\\"))
(vlax-put-property regex "Pattern" "\\x02")
(setq s(vlax-invoke-methodregex "Replace" s "{"))
(vlax-put-property regex "Pattern" "\\x03")
(setq s(vlax-invoke-methodregex "Replace" s "}"))
(vlax-release-object regex)
s
)
引用Gu_xl文本粘贴程序：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=90809&highlight=%D5%B3%CC%F9%2B%CE%C4%D7%D6
本帖最后由 Gu_xl 于 2011-12-2 18:06 编辑
为何不直接用(open filename "a")方法将文字写入文件？
下面提供两个剪贴板操作函数！
普通浏览复制代码
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif;;;将文本复制到剪贴板
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(defun CopytoClipboard(text / Clip_board)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(setq Clip_board (Vlax-Get-Property (Vlax-Get (vlax-create-object "htmlfile") 'ParentWindow) 'ClipboardData))
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(Vlax-Invoke Clip_board 'SetData "text" text)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(vlax-release-object Clip_board)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.giftext
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif;;;从剪贴板拷贝文本
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gifdefun GetClipboard(/ Clip_board text)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(setq Clip_board (Vlax-Get-Property (Vlax-Get (vlax-create-object "htmlfile") 'ParentWindow) 'ClipboardData))
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(setq text (Vlax-Invoke Clip_board 'GetData "text"))
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif(vlax-release-object Clip_board)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.giftext
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif)
这一段和上面功能差不多的，忘记是那一位大侠的作品，反正，你看下吧，这不是我的，作品产权属于原作者！;;; =================================================================*
;;; 功能：向系统剪贴板写入文字 *
(vl-load-com)
(defun ZML-CLIP-SETSTRING (STR / HTML RESULT)
(and
(= (type STR) 'STR)
(setq HTML (vlax-create-object "htmlfile"))
(setq RESULT (vlax-invoke (vlax-get (vlax-get HTML 'PARENTWINDOW)
'CLIPBOARDDATA
) 'SETDATA "Text" STR
)
)
(vlax-release-object HTML)
)
)
;;; =================================================================*
;;; 函数测试
(progn
(defun c:QC (/ txtss txtcon)
(setq txtss nil)
(while (= nil txtss)
(setq txtss (entsel "\n请点取文字:"))
(if (/= "TEXT" (cdr (assoc 0 (entget (car txtss)))))
(progn
(setq txtss nil)
(princ "\n没有点到文字，请重选。\n")
)
)
)
(setq txtcon (cdr (assoc 1 (entget (car txtss)))))
(ZML-CLIP-SETSTRING txtcon)
(princ "\n文字已复制到剪切板,可以直接粘贴了！")
(setq txtss nil)
(princ)
)
)
;;;
(defun c:QV (/ html)
(setq HTML (vlax-create-object "htmlfile"))
(vla-put-textstring (vlax-ename->vla-object (car (entsel "\n单击被替换的单行文字:")))
(vlax-invoke (vlax-get (vlax-get HTML 'PARENTWINDOW)
'CLIPBOARDDATA
) 'GETDATA "Text"
)
)
(princ)
)
剪切板经常不稳定 本帖最后由 alexmai 于 2021-5-25 00:13 编辑
小毛草 发表于 2021-5-24 20:28
这一段和上面功能差不多的，忘记是那一位大侠的作品，反正，你看下吧，这不是我的，作品产权属于原作者！;; ...
测试发现，ct 命令，不能copy属性块内某个文字，但可以copy，单独的文字
wt 命令，不能改属性块内的文字，普通文字是可以的，不能连续点击文字一直更改下去，直到 空点结束。
还请大侠改进改进，感谢！ 有办法加个上次读取到的文字吗，下次要用直接空格不要选择文字就可以刷了
页:
[1]