[LISP程序]：超级拆分修改文字
程序大意:点取一个文字（最好是TSSD字体，其他字体不敢保证正确）,程序将文字按文字类型拆开(如数字汉字、特殊钢筋符号、逗号、句号等）,然后再点取其中的一部分进行修改，修改完后右键结束，文字变成局部修改后的新的文字，比如我要修改KL-1（2） 250X500中的梁编号，先点取这个文字，然后再点取“1”，改成23，则最终文字变成KL-23（2） 250X500。不过这个代码还有问题需要解决,即:文字断开后会出现与原文字对不上的尴尬，我特别想实现TSSD中拆分文字的那种效果，只是苦于没找到方法，请高手支招，感谢之致。本程序与本论坛中的ddt命令很相似，不过我认为我这个更好。(defun c:g (/ numextra extrastrstrlist strlist1wz
obj objlist neirong pselect angtext ptext
key key0 num neirong1i j
k findindex stri numi type1 type2
entlist objlayer averageLp1 wz1 obj1
objlist1neirong0 neirong1objent neirongent
osvalue h templisthtextstyle
)
;直接改文字，目前不支持中文
(prompt "文字内容分拆修改")
(setq extrastr (list "%%130" "%%131" "%%132" "%%133"
"%%134" "%%135" "%%136" "%%137"
"%%138" "%%139" "%%140" "%%141"
"%%142" "%%143" "%%144" "%%145"
"%%146" "%%147" "%%u" "%%U"
"%%o" "%%O" "%%150" "%%151"
"%%152" "%%153" "%%154" "%%155"
"%%156" "%%157" "%%158" "%%159"
"%%200" "%%201" "%%202" "%%203"
"%%204" "%%205" "%%p" "%%P"
"%%c" "%%C" "%%d" "%%D"
)
) ;特殊字符，此表内的元素应互异
(setq oldstatus (dyq-get-oldstatus))
(setvar "OSMODE" 0)
(setq i 1)
(while (< i 46)
(setq extrastr (cons (chr i) extrastr))
(setq i (+ i 1))
)
(setq extrastr (cons "/" extrastr))
(setq i 58)
(while (< i 65)
(setq extrastr (cons (chr i) extrastr))
(setq i (+ i 1))
)
(setq i 91)
(while (< i 97)
(setq extrastr (cons (chr i) extrastr))
(setq i (+ i 1))
)
(setq i 123)
(while (< i 127)
(setq extrastr (cons (chr i) extrastr))
(setq i (+ i 1))
)
(defun wideofstring (str / a p1 p2 l)
(setq a (textbox (list (cons 1 str))))
(setq p1 (car a))
(setq p2 (cadr a))
(setq l (- (car p2) (car p1)))
)
(defun judgetype (s / ascNoi typestr) ;判断单字符s的类型：数字1、大小写字母2、其他3
(setq ascNoi (ascii s))
(cond ((and (>= ascNoi 48) (<= ascNoi 57)) (setq typestr 1))
((or (and (>= ascNoi 65) (<= ascNoi 90))
(and (>= ascNoi 97) (<= ascNoi 122))
)
(setq typestr 2)
)
((> ascNoi 160)
(setq typestr 4)
)
(t (setq typestr 3))
)
(if (= ascNoi 46)
(setq typestr 1)
)
typestr
)
(setq numextra (length extrastr)) ;extrastr表的元素的数目
(vl-load-com)
(setq strlist (list "string")) ;存储分割开后的文字内容
(if (setq wz (entsel "\n请选择要修改的文字:"))
;增加判断文字类型机制
(progn
;首先把TSSD里的特殊字符给柃出来
(setq obj (car wz))
(setq objlist (entget obj))
(setq neirong (cdr (assoc '1 objlist))) ;文字内容
(setq neirong (dyq-string-subst "？" " " neirong))
;用?来代替空格，没办法，只能牺牲?了
(setq objlist (subst (cons 1 neirong) (assoc '1 objlist) objlist))
(setq h (cdr (assoc '40 objlist))) ;文字高度
(setq htextstyle
(cdr (assoc '40
(tblsearch "style" (getvar "TEXTSTYLE"))
)
)
)
(if (< htextstyle 0.001)
(progn (command "-style" "" "" 300 0.7 0 "" "" "")
(setq htextstyle 300)
)
)
(setq pselect (cadr wz)) ;选择文字时的选择点
(setq angtext (cdr (assoc '50 objlist))) ;文字的角度
(setq ptext (cdr (assoc '10 objlist))) ;文字的左插入点
(setq objlayer (cdr (assoc '8 objlist))) ;文字的图层
(setq key 1) ;指针
(setq key0 1)
(setq num (strlen neirong)) ;文字的长度
(while (<= key num)
(setq neirong1 (substr neirong key))
(setq i 0)
(setq findindex -1)
(repeat numextra
(if (= (vl-string-search (nth i extrastr) neirong1) 0)
(setq findindex i)
)
(setq i (+ i 1))
)
(if (> findindex -1) ;如果搜索到特殊字符在第一的位置
(progn
(if (/= key0 key)
(setq
strlist (cons (substr neirong key0 (- key key0))
strlist
)
)
) ;连续的非特殊符号,如%%1308@100/200(2)中的100或200
(setq strlist (cons (nth findindex extrastr) strlist))
;将特殊符号加入strlist
(setq key (+ key (strlen (nth findindex extrastr))))
;key跳到下一个非特殊符号的地方
(setq key0 key)
)
(setq key (+ key 1))
)
)
(if (/= key0 key) ;处理尾巴
(setq strlist (cons (substr neirong key0 (- key key0))
strlist
)
)
)
(setq strlist (reverse strlist)) ;将表转置
;以下处理表内连续的字母、数字、汉字的情况，如G0.4、22本跨通长、G本跨通长、G42本跨通长的情况
(setq num (length strlist))
(setq strlist1 (list "string"))
(setq i 1)
(repeat (- num 1)
(setq stri (nth i strlist)) ;第i个元素内容
(if (member stri extrastr) ;如果是特殊字符
(setq strlist1 (cons stri strlist1))
;不作处理，直接调走
(progn ;如果不是特殊字符
(setq numi (strlen stri)) ;第i个元素的字符长度
(setq j 1)
(while (<= j numi)
(setq type1 (judgetype (substr stri j 1)))
;第一个字符的类型
(setq key T)
(setq k (+ j 1))
(while key
(setq type2 (judgetype (substr stri k 1)))
(if (= type2 type1)
(setq k (+ k 1))
(setq key nil)
)
)
(setq
strlist1 (cons (substr stri j (- k j)) strlist1)
)
(setq j k)
)
)
)
(setq i (+ i 1))
)
(setq strlist (reverse strlist1))
(setq i 1)
(setq ll 0)
(setq num (length strlist))
(repeat (- num 1)
(if (wcmatch (nth i strlist) "%%###")
(setq ll (+ ll 1))
(setq ll (+ ll (strlen (nth i strlist))))
)
(setq i (+ i 1))
)
(setq num (length strlist))
(setq p1 ptext)
(setq entlist (list "entlist"))
;用copy，先求尾巴之前的长度、坐标
(setq i 1)
(repeat (- num 1)
(setq j 1)
(setq neirong "")
(repeat (- i 1)
(setq neirong (strcat neirong (nth j strlist)))
(setq j (+ j 1))
)
(setq
objlist (subst (cons 1 neirong) (assoc '1 objlist) objlist)
)
(entmod objlist) ;将原文字改成
(setq wideofstring1 (dyq-get-wide-string obj))
(setq
objlist (subst (cons 1 (nth i strlist)) (assoc '1 objlist) objlist)
)
(entmod objlist)
(command "copy"
obj
""
p1
(polar p1 angtext wideofstring1)
)
(setq entlist (cons (entlast) entlist))
(setq i (+ i 1))
)
(setq
objlist (subst (cons 1 "") (assoc '1 objlist) objlist)
)
(entmod objlist) ;将原文字清空
(setq entlist (reverse entlist))
(while (setq wz1 (entsel "\n请选择要修改的部分:"))
(progn
(setq obj1 (car wz1))
(vla-Highlight (vlax-ename->vla-object obj1) :vlax-true)
(setq objlist1 (entget obj1))
(setq neirong0 (cdr (assoc '1 objlist1)))
(if (and (setq neirong1 (getstring "\n修改后的新内容:" T))
(/= neirong1 "")
)
(progn
(if (wcmatch neirong1 " ,, , ")
(setq neirong1 "")
)
(if (wcmatch neirong0 "%%13#")
;如果是钢筋符号则输入0、1、2、3等即可
(setq objlist1 (subst (cons 1
(strcat "%%13" neirong1)
)
(assoc '1 objlist1)
objlist1
)
)
(setq objlist1 (subst (cons 1 neirong1)
(assoc '1 objlist1)
objlist1
)
)
)
(entmod objlist1)
)
(progn
(setq objlist1 (subst (cons 1
neirong0
)
(assoc '1 objlist1)
objlist1
)
)
(entmod objlist1)
)
)
)
)
;以下重新连接字符
(setq neirong "")
(setq i 1)
(setq num (length entlist))
(repeat (- num 1)
(setq objent (nth i entlist))
(setq neirongent (cdr (assoc '1 (entget objent))))
(setq neirong (strcat neirong neirongent))
(setq i (+ i 1))
)
(setq i 1)
(setq num (length entlist))
(repeat (- num 1)
(entdel (nth i entlist)) ;将拆散的字删除
(setq i (+ i 1))
)
(while (> (vl-string-search "？" neirong) -1)
(setq neirong (vl-string-subst " " "？" neirong))
)
(setq objlist (subst (cons 1 neirong) (assoc '1 objlist) objlist))
(entmod objlist)
)
)
(dyq-put-oldstatus oldstatus)
(princ)
) 程序可以在CAD任何版本上用? 用find改不行么？ 思路很好，但执行后出现“ no function definition: DYQ-GET-OLDSTATUS”，请再看看 补上一个函数:
(defun dyq-get-oldstatus (/ oldstatus) ;存储系统原状态
(setq oldstatus (list "oldstatus"))
(setq oldstatus (cons "CLAYER" oldstatus))
(setq oldstatus (cons (getvar "CLAYER") oldstatus))
(setq oldstatus (cons "OSMODE" oldstatus))
(setq oldstatus (cons (getvar "OSMODE") oldstatus))
(setq oldstatus (cons "ORTHOMODE" oldstatus))
(setq oldstatus (cons (getvar "ORTHOMODE") oldstatus))
(setq oldstatus (cons "TEXTSTYLE" oldstatus))
(setq oldstatus (cons (getvar "TEXTSTYLE") oldstatus))
(setq oldstatus (cons "TEXTSIZE" oldstatus))
(setq oldstatus (cons (getvar "TEXTSIZE") oldstatus))
;当前标注样式要修改
(setq oldstatus (reverse oldstatus))
) 不知是否跟俺签名档里的 屏幕改字 有什么区别
应该是这个：
http://www.xdcad.net/forum/showthread.php?s=&threadid=248026&perpage=15&display=&pagenumber=2 能将文字拆分成单线形式吗? 文字变单线，express tools里有 我的程序不是将文字炸开，而是将"152不不不4564AAAA"拆分成“152不不不不4564AAAA"，然后分别修改，比如将152改成180，程序结束后文字就变成"180不不不4564AAAA"了，请大家不要搞错了。 还少一个函数：DYQ-STRING-SUBST (defun dyq-string-subst
(newtext oldtext textstring / n)
;替换时将革命进行到底，不仅仅是第一个替换
(while (> (vl-string-search oldtext textstring) -1)
(setq textstring (vl-string-subst newtext oldtext textstring))
)
textstring
) 还少一个函数：dyq-get-wide-string
补充一个函数
;获得文字的宽度(defun dyq-get-wide-string (obj / objlist minp maxp)
(setq objlist (entget obj))
(command "rotate"
obj
""
(cdr (assoc '10 objlist))
(angtos (* -1 (cdr (assoc '50 objlist))) 0 4)
)
(vla-getboundingbox
(vlax-ename->vla-object obj)
'minp
'maxp
)
(setq minp (vlax-safearray->list minp))
(setq maxp (vlax-safearray->list maxp))
(- (car maxp) (car minp))
) 看完之后，发现还是等楼主完善后在下来试试看了。希望楼主再接再厉，开发出更好的程序来！ 英雄寂寞，其实我的程序非常实用，本论坛没有识货的人，真是寂寞。
页:
[1]
2