帮忙写个批量修改文本属性的lisp

石井鱼

请哪位大侠写个小程序，功能如下：

框选图中文字，将文字属性修改：对齐方式改为左对齐；字高改为300；字宽改为0.6；字体颜色改为1号色；字体样式改为“TSSD_Rein”，如果没有定义，新创建该字体样式，英中字体分别为tssdeng.shx和tssdchn.shx。

以上功能单独的程序有，但是一个个用效率低，麻烦大侠给集合至一个命令，使用起来快捷些，先谢了。

恒毅

上面程序有点错误，现上传lsp

zwf100

自己把单独的程序改改就可以

石井鱼

zwf100 发表于 2016-1-17 20:06
自己把单独的程序改改就可以

菜鸟不会改，所以来求助帮忙的

恒毅

;|
框选图中文字，将文字属性修改：对齐方式改为左对齐；字高改为300；字宽改为0.6；
字体颜色改为1号色；字体样式改为“TSSD_Rein”，如果没有定义，新创建该字体样式，
英中字体分别为tssdeng.shx和tssdchn.shx。
|;
(defun c:test()
        (vl-load-com)
        ;;如果没有定义字体样式TSSD_Rein”，新创建该字体样式
        (setq ac (vla-get-ActiveDocument(vlax-get-acad-object)))
        (setq tt (vla-get-TextStyles ac))
        (if
                (vl-catch-all-error-p
                        (vl-catch-all-apply 'vla-Item (list tt "TSSD_Rein"))               
                )
                (entmake '(
                                                                (0 . "STYLE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbTextStyleTableRecord")
                                                                (2 . "TSSD_Rein")(70 . 0) (40 . 300) (41 . 0.6) (3 . "tssdeng.shx") (4 . "tssdchn.shx")
                                                        )       
                )
               
        )
       
        ;;更改选中文字属性
        (setq ss (ssget '((0 . "TEXT,MTEXT"))))
        (if ss                
                (setq vlalist (ssget->vla-list ss))               
        )
        (foreach obj vlalist
                (vlax-put-property obj 'StyleName "TSSD_Rein")
                (vlax-put-property obj 'Height 300)
                (setq en (vlax-vla-object->ename obj)
                        ent (entget en)
                        old72 (assoc 72 ent)
                        old73 (assoc 73 ent)
                        nent (subst (cons 72 0) old72 ent)
                        nent (subst (cons 73 0) old73 nent)                       
                )
                (entmod nent)
                (vla-put-Color obj 1)
               
        )
       
)
(defun ssget->vla-list (ss / i ename lst)
        (setq i -1)
        (while (setq ename (ssname ss (setq i (1+ i))))
                (setq lst (cons (vlax-ename->vla-object ename) lst))
        )
        lst
)

石井鱼

恒毅 发表于 2016-1-26 17:27
上面程序有点错误，现上传lsp

万分感谢恒毅，辛苦写了这么好的程序，工作中经常用的，再次感谢帮大忙！