langjs 发表于 2021-6-14 09:43:15

字体统一文字样式(支持标注、属性块、嵌套块内文字)

编了一个小程序，觉得还挺好用的就发出来分享一下。
缺点是运行速度有点慢，有兴趣的网友可以优化一下。

;;; ====================================================
;;; 名称：字体统一文字样式(支持标注、属性块、嵌套块内文字)
;;; 说明：选择一个样本字体，将框选字体统一成样本字体样式
;;; 命令：ztty　          　by：langjs      2021.6.13
;;; ====================================================
(defun c:ztty (/ blk bname ent ent1 i kua lst n name name0 name1 ss sty tp ty)
(defun #errxts (s)                     ; 出错处理程序
    (redraw name0 4)
    (command ".UNDO" "E")
    (setq *error* $orr)
    (princ)
)
(defun emod (ent i n)
    (subst
      (cons i n)
      (assoc i ent)
      ent
    )
)
(defun kualst (bname / blk kua lst name1 ty) ; 获取含嵌套块内对象(来自明经)
    (setq kua (cdr (assoc 2 (entget bname))))
    (setq blk (tblobjname "Block" kua))
    (while (setq name1 (entnext blk))
      (setq ty (cdr (assoc 0 (entget name1))))
      (if (= ty "INSERT")
        (setq lst (cons name1 lst)
              lst (append
                  (kualst name1)
                  lst
                  )
        )
        (setq lst (cons name1 lst))
      )
      (setq blk name1)
    )
    lst
)
(vl-load-com)                             ; 主程序开始
(setq $orr *error*)
(setq *error* #errxts)
(setvar "cmdecho" 0)
(while (not (and
                (setq name1 (nentsel "\n请选取文字样本："))
                (setq name0 (car name1))
                (setq ent (entget name0))
                (setq ty (cdr (assoc 0 ent)))
                (setq sty (cdr (assoc 7 ent)))
                (member ty (list "TEXT" "MTEXT" "ATTRIB"))
              )
       )
    (if (= 52 (getvar "errno"))
      (vl-exit-with-error "")
    )
)
(redraw name0 3)
(if (setq ss (ssget '((0 . "TEXT,MTEXT,INSERT,DIMENSION"))))
    (progn
      (command ".UNDO" "BE")
      (repeat (setq i (sslength ss))
        (setq ent (entget (setq name (ssname ss (setq i (1- i)))))
              tp (cdr (assoc 0 ent))
        )
        (cond
          ((member tp '("TEXT" "MTEXT"))
          (entmod (emod ent 7 sty))
          )
          ((= tp "DIMENSION")
          (command "DIMOVERRIDE" "DIMTXSTY" sty "dimfit" 3 "" name "")
          (entmod ent)
          )
          ((member tp '("INSERT"))
          (setq ent1 ent)
          (while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
              (setq ent1 (emod ent1 7 sty))
              (entmod ent1)
              (entmod ent)
          )
          (setq lst (kualst name))
          (foreach name1 lst
              (setq ent1 (entget name1))
              (if (member (cdr (assoc 0 ent1)) '("TEXT" "MTEXT"))
                (entmod (emod ent1 7 sty))
              )
          )
          (entmod ent)
          )
        )
      )
      (command "regen")
      (command ".UNDO" "E")
    )
)
(redraw name0 4)
(setq *error* $orr)
(princ)
)


alexmai 发表于 2021-9-6 17:03:40

oohen 发表于 2021-9-6 14:17
我也是一样情况具体怎么解决？？

选这个保存

wide 发表于 2024-3-14 15:12:15

本帖最后由 wide 于 2024-3-14 15:13 编辑

标注中的文字样式，只是选择的标注中的文字样式改了，不是统一改某一个标注样式的文字样式。比如50的标注样式有10个，只选择了3个，3个文字样式改了，其它的7个没改。如果是整个50的标注样式全改就完美了。点开标注样式后里面的文字样式没有改变，还是原来的。{:1_1:}

alexmai 发表于 2021-6-15 10:25:32

本帖最后由 alexmai 于 2021-6-16 10:38 编辑

cad 201064位

(LOAD "C:/Users/Administrator/Desktop/字体统一.lsp") ; 错误: 输入中的点位置不正确

找到原因了：win10 文本默认存为   编码： utf-8

paulpipi 发表于 2021-6-14 21:06:36

感 谢 分享

zhangkui9070 发表于 2021-6-15 07:01:11

厉害，支持

sowin 发表于 2021-6-15 08:38:46

p-3-ianlcc 发表于 2021-6-16 10:31:19

厲害厲害！
AUTOCAD2016使用正常！

GNJLISP 发表于 2021-6-16 17:28:39

一直用着大佬 的很多好程序，感谢

czb203 发表于 2021-6-17 22:36:01

一直用着大佬 的很多好程序，感谢

magicheno 发表于 2021-6-19 19:30:46

狼大师真牛~~~~

依然小小鸟 发表于 2021-6-19 22:45:08

有没有强制图纸线性比例 为1的小程序
页: [1] 2 3
查看完整版本: 字体统一文字样式(支持标注、属性块、嵌套块内文字)