帮忙写个批量修改文本属性的lisp
请哪位大侠写个小程序，功能如下：框选图中文字，将文字属性修改：对齐方式改为左对齐；字高改为300；字宽改为0.6；字体颜色改为1号色；字体样式改为“TSSD_Rein”，如果没有定义，新创建该字体样式，英中字体分别为tssdeng.shx和tssdchn.shx。
以上功能单独的程序一个个用效率低，麻烦大侠给集合至一个命令，使用起来快捷些，先谢了。
本帖最后由 437271963 于 2016-2-29 14:34 编辑
;建立TSSD_Rein字体
(defun TSSD_Rein ( / newt)
(if (null (tblsearch "style" "TSSD_Rein"))
(progn
(if (null vlax-dump-object) (vl-load-com) )
(setq newT (vla-add (vla-get-TextStyles (vla-get-activedocument (vlax-get-acad-object))) "TSSD_Rein"))
(vla-put-fontfile newT "tssdeng.shx")
(vla-put-bigfontfile newT "tssdchn.shx");大字体为hztxt
(vla-put-height newT 0);高度0
(vla-put-width newT 0.6);宽度因子0.6
(vla-put-obliqueAngle newT (/ (* pi 3) 180));倾斜角度3
)
)
)
;;修改文字为左对齐位置不变;;
(defun C:tes ( / #g1 &k1 &kw1 &ob1 pt1 ss1 ss2 ss3 ss4 ss5 x)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(if (null vlax-dump-object) (vl-load-com) );;加载vlax扩展函数
(setq ss5 '((62 . 1) (40 . 300) (41 . 0.6) (7 . "TSSD_Rein")))
(TSSD_Rein)
(princ "\n请选择文字")
(if (setq &kw1 (ssget '((0 . "TEXT"))));1
(progn;;1
(setq ss1 '(0 8) ss2 '(1 50 51))
(while (setq &k1 (ssname &kw1 0));1
(setq &kw1 (ssdel &k1 &kw1))
(setq #g1 (entget &k1) &ob1 (vlax-ename->vla-object &k1))
(setq ss3 (vl-remove-if-not '(lambda (X) (member (car x) ss1)) #g1))
(setq ss4 (vl-remove-if-not '(lambda (X) (member (car x) ss2)) #g1))
(setq pt1 (Vlax-SafeArray->List (Vlax-Variant-Value (vla-get-InsertionPoint &ob1))))
(setq pt1 (list (car pt1) (cadr pt1)));坐标Z为0
(vla-delete &ob1);删除原来的文字
(setq ss4 (append ss5 ss4))
(setq ss4 (cons (cons 10 pt1) ss4))
(setq ss3 (append ss3 ss4))
(entmake ss3);绘制文字
);while;1
);progn;1
);if;1
(prin1)
) 已经解决，感谢明经 高，这个真的还有
437271963 发表于 2016-2-28 19:15 static/image/common/back.gif
非常感谢437271963帮忙，辛苦编写了这段很好的程序，适用了一下，发现其他都很实现了，但是字体样式没有改过来，新字体样式是生成了，就是没有所选文字没有变，不知能否再完善一下，再次感谢！ 已经重新修正。 OK，完美，谢谢437271963的热心帮助，感谢明经这个平台！ 看看。
页:
[1]