批量改文字高度
昨天写了个改文字高度的程序，大伙帮我看看有改进的地方吗，多谢(defun C:matext (/ a b n ss aa ss1 h)
(setq ss (ssget))
(setq loop T)
(setq n 0)
(while loop
(setq h (getstring "\n请输入新文本高度[选取对象(S)][选取两点(D)]:"))
(cond ((or (= h "s") (= h "S"))
(while loop
(princ "\n选取文字:")
(setq ss1 (entsel))
(if (= ss1 nil)
(progn
(princ "\n选取文字:")
(setq loop t)
)
(progn
(setq ss2 (entget (car ss1)))
(setq aa (cdr (assoc 0 ss2)))
(if (or (= "TEXT" aa) (= "MTEXT" aa))
(progn
(setq h (cdr (assoc 40 ss2)))
(setq loop nil)
)
)
)
)
)
)
((numberp (read h))
(setq h (atof h)
loop nil
)
)
((or (= h "d") (= h "D"))
(progn
(setq h (getdist "\n请选取两点:"))
(setq loop nil)
)
)
(T
(setq loop T)
)
)
)
(repeat (sslength ss)
(setq a (ssname ss n))
(setq b (entget a))
(if (or (= "TEXT" (cdr (assoc 0 b)))(= "MTEXT" (cdr (assoc 0 b))) )
(progn
(setq b (subst (cons 40 h) (assoc 40 b) b))
(if (= 3 (cdr (assoc 72 b)))
(setq b (subst (cons 72 0) (assoc 72 b) b))
)
(entmod b)
)
)
(setq n (1+ n))
)
(print "文字高度已改为：")
(print h)
)
(princ "\n by pzweng 命令:matext")
本帖最后由 革天明 于 2012-7-18 08:50 编辑
谢谢楼主分享，很好 谢谢楼主的分享！
先收藏看看
谢谢！ 支持源码，搞了一个短点的，但是只针对text，共同学习(defun ch_dxf(en num ch / old_num new_num ent)
(if (setq ent (entget en)
new_num (cons num ch)
old_num (assoc num ent)
)
(entmod(subst new_num old_num ent))
(entmod(reverse(cons new_num (reverseent))))
))
(defun c:test1( / ss n x ww)
(setq ss (ssget '((0 . "text"))))
(setq ww (getreal "请输入字高："))
(repeat (setq N (sslength SS))
(apply '(lambda (x) (ch_dxf x 40 ww))
(list (ssname SS (setq N (1- N))))
)
)
(princ)
)
(defun c:test2( / ss n x ww)
(setq ss (ssget '((0 . "text"))))
(setq ww (getreal "请输入长高比："))
(repeat (setq N (sslength SS))
(apply '(lambda (x) (ch_dxf x 41 ww))
(list (ssname SS (setq N (1- N))))
)
)
(princ)
) 好样的，顶楼主，
;; 改换字高
;; 伪源码需要e派工具箱(XCAD)的支持
(defun c:tt ()
(CMDLA0)
(xyp-initSet '(ukw th) '("1" 500.))
(setq ukw (UKWORD 1 "1 2" "高度方式: 1-选样板/2-两点" ukw))
(if (= ukw "1")
(if (and (setq s1 (car (entsel "\n选择文本: ")))
(xyp-etype s1 "text,mtext")
)
(setq th (xyp-get-dxf 40 s1))
(setq th 500)
)
(setq th (Udist 1 "" "高度<输入或鼠标直接量取>" th nil))
)
(setq ss (ssget '((0 . "*TEXT")))
i-1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(xyp-SubUpd s1 40 th)
)
(CMDLA1)
)
xyp1964 发表于 2012-7-18 13:32 static/image/common/back.gif
如简洁，可惜全是伪源码 这个学习学习。 x_s_s_1 发表于 2012-7-18 09:56 static/image/common/back.gif
支持源码，搞了一个短点的，但是只针对text，共同学习
(apply '(lambda (x) (ch_dxf x 40 ww))
这段怎么理解，望兄台指点 pzweng 发表于 2012-7-19 12:51 static/image/common/back.gif
(apply '(lambda (x) (ch_dxf x 40 ww))
这段怎么理解，望兄台指点
(apply '(lambda (x) (ch_dxf x 40 ww)) lsp)就是对lsp（图元表）中的每个图元进行更换40组码的操作