社区 › AutoLISP/Visual LISP 编程技术 › 文字刷-支持块内及部份天正文字（借鉴阿甘的贴仿写）

wzg356 发表于 2025-2-21 21:13:35

文字刷-支持块内及部份天正文字（借鉴阿甘的贴仿写）

本帖最后由 wzg356 于 2025-2-22 22:48 编辑

好久不动，练手，参考阿甘文字刷仿写
命令(maTextStr "69999hudd")或maTxt
下载文件"刷文本内容.lsp"含单多行限/不限模两种式切换---仅1行的多行文本MTEXT也算单行文本
刷新时：块内文字只能点选，其余点/框选均可，选不中文字/回车/右键结束

;刷文字工具
(vl-load-com)
;=================
;获取或刷新文本图元内容
;参数Str：nil则获取文本或用新字符串Str更新文本
;成功获取/更新文本则返回字符串，否则返回nil
;(GetORPutStr (car(entsel)) nil)
;(GetORPutStr (car(entsel)) "AFFFAA")
(defun GetORPutStr(e Str / ob obn str0)
      (setq ob(vlax-ename->vla-object e))
      (setq obn(Vlax-Get ob 'ObjectName))      
      (car(vl-remove NIL(mapcar
                (function(lambda(x)
                (setq str0 (vl-catch-all-apply 'Vlax-Get (list ob x)))
                (if (not(vl-catch-all-error-p str0))
                (if (and str
                        (not(vl-string-search "\\P" str0))
                        (not(vl-string-search "\n" str0))
                        ;(not(vl-string-search "\t" str0))
                        );限制更新有多行的文本
                        (progn(Vlax-Put ob X str) str) str0)
                )))
                (vl-remove
                        (if (= obn "AcDbAttributeDefinition")'TextString
                              (if(= obn "AcDbAttribute") 'TagString)
                        );属性文本仅标签值，块内属性取属性值
                        '(TextString Text UpText NameText Text2 DownText TagString)
                )
      )));含更新下标Text2 DownText，取文字内容时仅取上标
)
;(maTextStr "69999hudd")
(defun maTextStr(str / flter ss e0 e1 n)
      (setq flter(strcat
      "TEXT,MTEXT,ATTDEF,ATTRIB,*MULTILEADER,"; 含天正引线
      "TCH_TEXT,TCH_MTEXT,TCH_ARROW,TCH_ELEVATION,TCH_DRAWINGNAME"
      ;天正单/多行、箭头、标高、图名
      ))
      (alert(strcat
                "块内文字需拾取,其他可框取\n内容刷新为:\n"
                str      "\n\n下一步\n拾取或框取要刷新的文本<>:\n"
      ))
      (while
                (setq ss(ssget ":s" (list(cons 0 (strcat"INSERT," flter)))))
                (or(and
                        (= (caar (setq e0(ssnamex ss 0))) 1)
                        (setq e1(car (nentselp (trans (cadar(cdddar e0)) 0 1))))
                        (wcmatch (cdr(assoc 0(entget e1))) flter)
                        (GetORPutStr e1 str)
                        (entupd e1)(entupd(cadar e0))                        
                        );处理块内文字
                        (repeat (setq n(sslength ss))
                              (setq e1(ssname ss (setq n(1- n))))
                              (GetORPutStr e1 str)
                              (entupd e1)
                        )
                )
      )
)
(defun c:maTxt( / str)
      (and (setq str (car(Nentsel "\n文字刷工具\n拾取新文本<>:")))
                (setq str(GetORPutStr str nil))
                (maTextStr str)
      )      
)

wzg356 发表于 2025-2-21 21:31:23

本帖最后由 wzg356 于 2025-2-21 21:32 编辑

有文本的天正实体有以下这些（老版本资料）
"TCH*TEXT,TCH_AXIS_LABEL,TCH_ARROW,TCH_COMPOSING,TCH_COORD,TCH_ELEVATION"
",TCH_DRAWINGNAME,TCH_INDEXPOINTER,TCH_INDEXPOINTER,TCH_SYMB_SECTION"
",TCH_CORNER_WINDOW,TCH_DORMER,TCH_ERRORMSG,TCH_SPACE"
有编程基础的可以查证特性符号后，根据需求添加完善
我没用过天正

wzg356 发表于 2025-2-24 16:11:10

朦胧Design 发表于 2025-2-24 13:01
大佬，这个能不能刷的同时递增呢。

没空写，该类工具论坛多啊

p-3-ianlcc 发表于 2025-2-22 14:29:02

谢谢楼主的分享！
copy下来使用看看

moranyuyan 发表于 2025-2-22 07:45:31

谢谢分享

yshf 发表于 2025-2-22 08:21:40

谢谢分享

fate_color 发表于 2025-2-22 08:54:18

好用，谢谢大佬

panliang9 发表于 2025-2-22 10:20:00

谢谢楼主分享！

muai2010 发表于 2025-2-23 14:53:43

支持大佬分享

朦胧Design 发表于 2025-2-24 13:01:17

大佬，这个能不能刷的同时递增呢。

查看完整版本: 文字刷-支持块内及部份天正文字（借鉴阿甘的贴仿写）