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

langjs

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

;;; ====================================================
;;; 名称：字体统一文字样式(支持标注、属性块、嵌套块内文字)
;;; 说明：选择一个样本字体，将框选字体统一成样本字体样式
;;; 命令：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

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

选这个保存

wide

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

alexmai

cad 2010  64位  

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

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

paulpipi

感 谢 分享

zhangkui9070

厉害，支持

sowin

p-3-ianlcc

厲害厲害！
AUTOCAD2016使用正常！

GNJLISP

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

czb203

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

magicheno

狼大师真牛~~~~

依然小小鸟

有没有强制图纸线性比例 为1的小程序