liu_kunlun
发表于 2009-9-29 19:11:00
你的程序中，(setq d0 (cdr(assoc 40 (entget ssd))))<br/>改为(setq d0 (vla-get-TextHeight (vlax-ename->vla-object ssd)))即可！
狂刀无痕
发表于 2009-9-29 19:56:00
关于标注的字高，n年前明总写过一个vba的，我也跟着搞过一个lisp的。你搜索一下
啵浪鼓
发表于 2009-9-29 23:53:00
<p>谢谢各位,改TEXT/MTEXT/DMINENSION字高的程序终于完成,以下贴出这段程序的代码,希望有用的人用上,其实程序可以再简单,但能力有限,就写出这个程序也花了一周时间,还要到处搜代码,晕S了</p><p>以下代码美中不中的是,由于采用ssget,所以如果存在所选字高不一样时,程序报字高只能随机选一个为参考</p><p>程序的目的是将所选TEXT/MTEXT/DMINENSION改字高,比如所选TEXT字里有字高为5和6的,将一并改为用户所输入的新字高,如果用户不输字高将放弃所有TEXT字高</p><p>(defun c:tc ()<br/> (princ "Modify TEXT Height")<br/> (setvar "cmdecho" 0)<br/> (command "undo" "be")<br/> (defun *error*(msg)<br/> (if (and (not (wcmatch msg "*函数被取消")) (/= msg "quit / exit abort"))<br/> (princ (strcat "\n" msg))<br/> )<br/> (command "_.undo" "_e")<br/> (setvar "cmdecho" 0)<br/> (setq *error* nil)<br/> (princ)<br/> )<br/> (setq ss (ssget '((0 . "TEXT,MTEXT,DIMENSION"))))<br/> (setq tt3 (ssadd) mm3 (ssadd) dd3 (ssadd) i 0)<br/> (while (< i (sslength ss))<br/> (setq en(ssname ss i))<br/> (if (= "TEXT" (cdr (assoc 0 (entget en)))) <br/> (ssadd (ssname ss i) tt3)<br/> )<br/> (if (= "MTEXT" (cdr (assoc 0 (entget en)))) <br/> (ssadd (ssname ss i) mm3)<br/> )<br/> (if (= "DIMENSION" (cdr (assoc 0 (entget en)))) <br/> (ssadd (ssname ss i) dd3)<br/> )<br/> (setq i (+ i 1))<br/> )<br/> (setq i 0)<br/> (setq sst (ssname tt3 i) ssm (ssname mm3 i) ssd (ssname dd3 i))<br/> (if (/= nil sst)<br/> (progn<br/> (setq t0 (cdr(assoc 40 (entget sst))))<br/> (princ (strcat "\n<" (itoa (sslength tt3)) " 个TEXT高度为" (rtos (cdr(assoc 40 (entget sst)))) ">"))<br/> (initget (+ 2 4))<br/> (setq th (getdist "\n请输入新的字高:"))<br/>; (if (null th)(setq th t0))<br/> )<br/> )<br/> (if (/= nil ssm)<br/> (progn<br/> (setq m0 (cdr(assoc 40 (entget ssm))))<br/> (princ (strcat "\n<" (itoa (sslength mm3)) " 个MTEXT高度为" (rtos (cdr(assoc 40 (entget ssm)))) </p><p>">"))<br/> (initget (+ 2 4))<br/> (setq mh (getdist "\n请输入新的字高:"))<br/>; (if (null mh)(setq mh m0))<br/> )<br/> )<br/> (if (/= nil ssd)<br/> (progn<br/> (setq d0 (vla-get-TextHeight (vlax-ename->vla-object ssd)))<br/> ;(setq d0 (cdr(assoc 40 (entget ssd))))<br/> (princ (strcat "\n<" (itoa (sslength dd3)) " 个DIM高度为" (rtos d0) ">"))<br/> (initget (+ 2 4))<br/> (setq dh (getdist "\n请输入新的字高:"))<br/>; (if (null dh)(setq dh d0))<br/> )<br/> )<br/> (setq i 0)<br/> (if (/= nil th)<br/> (progn<br/> (repeat (sslength tt3)<br/> (setq sit (ssname tt3 i))<br/> (setq tht (entget sit) tht (subst (cons 40 th) (assoc 40 tht) tht))<br/> (entmod tht)<br/> (setq i (+ i 1))<br/> )<br/> )<br/> (princ "|TEXT未作修改|")<br/> )</p><p> (setq i 0)<br/> (if (/= nil mh)<br/> (progn<br/> (repeat (sslength mm3)<br/> (setq sim (ssname mm3 i))<br/> (setq thm (entget sim)<br/> old_h (cdr (assoc 40 thm))<br/> old_w (cdr (assoc 41 thm))<br/> new_w (* old_w (/ mh old_h))<br/> thm (subst (cons 40 mh) (assoc 40 thm) thm)<br/> thm (subst (cons 41 new_w) (assoc 41 thm) thm)<br/> )<br/> (entmod thm)<br/> (setq i (+ i 1))<br/> )<br/> )<br/> (princ "|MTEXT未作修改|")<br/> )</p><p> (setq i 0)<br/> (if (/= nil dh)<br/> (progn<br/> (repeat (sslength dd3)<br/> (setq sid (ssname dd3 i))<br/> (setq h1 (/ dh 1.5) h2 (/ dh 5))<br/> (command "dimoverride" "dimtxt" dh "dimasz" h1 "dimexe" h2 "dimexo" h2 "" sid "")<br/> (setq i (+ i 1))<br/> )<br/> )<br/> (princ "|DIMENSION未作修改|")<br/> )<br/>(*error* "")<br/>)</p>