文字刷-改进使用要求

alexmai

制图中经常要修改 索引号中的文字，例如 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-method  regex "Replace" s (chr 1)))
     ;替换\{字符
  (vlax-put-property regex "Pattern" "\\\\{")
  (setq s(vlax-invoke-method  regex "Replace" s (chr 2)))
     ;替换\}字符
  (vlax-put-property regex "Pattern" "\\\\}")
  (setq s(vlax-invoke-method  regex "Replace" s (chr 3)))
     ;删除段落缩进格式
  (vlax-put-property regex "Pattern" "\\\\pi(.[^;]*);")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除制表符格式
  (vlax-put-property regex "Pattern" "\\\\pt(.[^;]*);")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除堆迭格式
  (vlax-put-property regex "Pattern" "\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
  (vlax-put-property regex "Pattern" "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除下划线、删除线格式
  (vlax-put-property regex "Pattern" "(\\\\L|\\\\O|\\\\l|\\\\o)")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除不间断空格格式
  (vlax-put-property regex "Pattern" "\\\\~")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除换行符格式
  (vlax-put-property regex "Pattern" "\\\\P")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除换行符格式(针对Shift+Enter格式)
  (vlax-put-property regex "Pattern" "\n")
  (setq s(vlax-invoke-method  regex "Replace" s ""))
     ;删除{}
  (vlax-put-property regex "Pattern" "({|})")
  (setq s(vlax-invoke-method  regex "Replace" s ""))

     ;替换回\\,\{,\}字符
  (vlax-put-property regex "Pattern" "\\x01")
  (setq s(vlax-invoke-method  regex "Replace" s "\\"))
  (vlax-put-property regex "Pattern" "\\x02")
  (setq s(vlax-invoke-method  regex "Replace" s "{"))
  (vlax-put-property regex "Pattern" "\\x03")
  (setq s(vlax-invoke-method  regex "Replace" s "}"))

  (vlax-release-object regex)
  s
)



引用Gu_xl文本粘贴程序：http://bbs.mjtd.com/forum.php?mo ... C%F9%2B%CE%C4%D7%D6

本帖最后由 Gu_xl 于 2011-12-2 18:06 编辑 为何不直接用(open filename "a")方法将文字写入文件？ 下面提供两个剪贴板操作函数！ 普通浏览复制代码 ;;;将文本复制到剪贴板 (defun CopytoClipboard(text / Clip_board) (setq Clip_board (Vlax-Get-Property (Vlax-Get (vlax-create-object "htmlfile") 'ParentWindow) 'ClipboardData)) (Vlax-Invoke Clip_board 'SetData "text" text)   (vlax-release-object Clip_board)   text ) ;;;从剪贴板拷贝文本 defun GetClipboard(/ Clip_board text) (setq Clip_board (Vlax-Get-Property (Vlax-Get (vlax-create-object "htmlfile") 'ParentWindow) 'ClipboardData)) (setq text (Vlax-Invoke Clip_board 'GetData "text"))   (vlax-release-object Clip_board)   text )

小毛草

这一段和上面功能差不多的，忘记是那一位大侠的作品，反正，你看下吧，这不是我的，作品产权属于原作者！;;; =================================================================*
;;; 功能：向系统剪贴板写入文字                                       *
(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-24 20:28
这一段和上面功能差不多的，忘记是那一位大侠的作品，反正，你看下吧，这不是我的，作品产权属于原作者！;; ...

测试发现，ct 命令，不能copy属性块内某个文字，但可以copy，单独的文字

                 wt 命令，不能改属性块内的  文字，普通文字是可以的，不能连续点击文字一直更改下去，直到 空点  结束。

还请大侠改进改进，感谢！

LoyaltyMu

有办法加个上次读取到的文字吗，下次要用直接空格  不要选择文字就可以刷了