[求助]文字改高度

liu_kunlun

你的程序中，(setq d0 (cdr(assoc 40 (entget ssd))))
改为(setq d0 (vla-get-TextHeight (vlax-ename->vla-object ssd)))即可！

狂刀无痕

关于标注的字高，n年前明总写过一个vba的，我也跟着搞过一个lisp的。你搜索一下

啵浪鼓

谢谢各位,改TEXT/MTEXT/DMINENSION字高的程序终于完成,以下贴出这段程序的代码,希望有用的人用上,其实程序可以再简单,但能力有限,就写出这个程序也花了一周时间,还要到处搜代码,晕S了

以下代码美中不中的是,由于采用ssget,所以如果存在所选字高不一样时,程序报字高只能随机选一个为参考

程序的目的是将所选TEXT/MTEXT/DMINENSION改字高,比如所选TEXT字里有字高为5和6的,将一并改为用户所输入的新字高,如果用户不输字高将放弃所有TEXT字高

(defun c:tc ()
  (princ "Modify TEXT Height")
  (setvar "cmdecho" 0)
  (command "undo" "be")
  (defun *error*(msg)
    (if (and (not (wcmatch msg "*函数被取消")) (/= msg "quit / exit abort"))
        (princ (strcat "\n" msg))
    )
    (command "_.undo" "_e")
    (setvar "cmdecho" 0)
    (setq *error* nil)
    (princ)
  )
  (setq ss  (ssget '((0 . "TEXT,MTEXT,DIMENSION"))))
  (setq tt3 (ssadd) mm3 (ssadd) dd3 (ssadd) i 0)
  (while (< i (sslength ss))
     (setq en(ssname ss i))
     (if (= "TEXT" (cdr (assoc 0 (entget en))))        
         (ssadd (ssname ss i) tt3)
     )
     (if (= "MTEXT" (cdr (assoc 0 (entget en))))        
         (ssadd (ssname ss i) mm3)
     )
     (if (= "DIMENSION" (cdr (assoc 0 (entget en))))        
         (ssadd (ssname ss i) dd3)
     )
     (setq i (+ i 1))
  )
     (setq  i 0)
     (setq sst (ssname tt3 i) ssm (ssname mm3 i) ssd (ssname dd3 i))
     (if (/= nil sst)
       (progn
         (setq t0 (cdr(assoc 40 (entget sst))))
         (princ (strcat "\n<" (itoa (sslength tt3)) " 个TEXT高度为" (rtos (cdr(assoc 40 (entget sst)))) ">"))
         (initget (+ 2 4))
         (setq th (getdist "\n请输入新的字高:"))
;         (if (null th)(setq th t0))
       )
     )
     (if (/= nil ssm)
       (progn
         (setq m0 (cdr(assoc 40 (entget ssm))))
         (princ (strcat "\n<" (itoa (sslength mm3)) " 个MTEXT高度为" (rtos (cdr(assoc 40 (entget ssm))))

">"))
         (initget (+ 2 4))
         (setq mh (getdist "\n请输入新的字高:"))
;         (if (null mh)(setq mh m0))
       )
     )
     (if (/= nil ssd)
       (progn
         (setq d0 (vla-get-TextHeight (vlax-ename->vla-object ssd)))
         ;(setq d0 (cdr(assoc 40 (entget ssd))))
         (princ (strcat "\n<" (itoa (sslength dd3)) " 个DIM高度为" (rtos d0) ">"))
         (initget (+ 2 4))
         (setq dh (getdist "\n请输入新的字高:"))
;         (if (null dh)(setq dh d0))
       )
     )
  (setq i 0)
  (if (/= nil th)
    (progn
       (repeat (sslength tt3)
         (setq sit (ssname tt3 i))
         (setq tht (entget sit) tht (subst (cons 40 th) (assoc 40 tht) tht))
         (entmod tht)
         (setq i (+ i 1))
       )
    )
    (princ "|TEXT未作修改|")
  )

  (setq i 0)
  (if (/= nil mh)
     (progn
       (repeat (sslength mm3)
         (setq sim (ssname mm3 i))
         (setq thm (entget sim)
              old_h (cdr (assoc 40 thm))
              old_w (cdr (assoc 41 thm))
              new_w (* old_w (/ mh old_h))
              thm (subst (cons 40 mh) (assoc 40 thm) thm)
              thm (subst (cons 41 new_w) (assoc 41 thm) thm)
  )
         (entmod thm)
         (setq i (+ i 1))
       )
    )
    (princ "|MTEXT未作修改|")
  )

  (setq i 0)
  (if (/= nil dh)
     (progn
       (repeat (sslength dd3)
         (setq sid (ssname dd3 i))
         (setq h1 (/ dh 1.5) h2 (/ dh 5))
         (command "dimoverride" "dimtxt" dh "dimasz" h1 "dimexe" h2 "dimexo" h2 "" sid "")
         (setq i (+ i 1))
       )
     )
     (princ "|DIMENSION未作修改|")
  )
(*error* "")
)