批量改文字高度

pzweng · 发表于 2012-7-18 08:08:24

昨天写了个改文字高度的程序，大伙帮我看看有改进的地方吗，多谢
(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:34:05

本帖最后由革天明于 2012-7-18 08:50 编辑

谢谢楼主分享，很好

461045462 · 发表于 2012-7-18 09:04:09

谢谢楼主的分享！
先收藏看看
谢谢！

x_s_s_1 · 发表于 2012-7-18 09:56:26

支持源码，搞了一个短点的，但是只针对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 (reverse ent))))
))
(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)
)

lty · 发表于 2012-7-18 12:03:35

好样的，顶楼主，

xyp1964 · 发表于 2012-7-18 13:32:21

;; 改换字高
;; 伪源码需要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)
)

pzweng · 发表于 2012-7-18 14:11:31

xyp1964 发表于 2012-7-18 13:32

如简洁，可惜全是伪源码

昵称 · 发表于 2012-7-18 18:54:08

这个学习学习。

pzweng · 发表于 2012-7-19 12:51:13

x_s_s_1 发表于 2012-7-18 09:56
支持源码，搞了一个短点的，但是只针对text，共同学习

(apply '(lambda (x) (ch_dxf x 40 ww))
这段怎么理解，望兄台指点

x_s_s_1 · 发表于 2012-7-19 15:16:53

pzweng 发表于 2012-7-19 12:51
(apply '(lambda (x) (ch_dxf x 40 ww))
这段怎么理解，望兄台指点

(apply '(lambda (x) (ch_dxf x 40 ww)) lsp)就是对lsp（图元表）中的每个图元进行更换40组码的操作

账号		自动登录	找回密码
密码			注册

批量改文字高度

点评