求“不存在的字体”批量替换程序lsp

sctw · 发表于 2020-8-2 00:05

哪位大神能帮助写个完美的程序，当遇到需要字体替换时，如下图：
哪怕是选择了已有的字体，在字体样式中就会有黄色叹号，很多字体还是会显示不正确。

希望能编写个lsp程序，达到
1、把字体名仅是黄色中文叹号的，可选windows系统中有的任意中文进行替换，
2、把shx字体和大字体中有黄色叹号的替换成CAD中fonts目录中任意的字体进行替换。
类似下图界面功能：

期待回复，QQ：371835653

gaics · 发表于 2020-8-2 00:05

本帖最后由 gaics 于 2020-8-12 19:21 编辑

(defun c:tt (/ a b c d e err)
(vl-load-com)
(setvar "cmdecho" 0)
(command "undo" "be")
(vlax-for x (vla-get-textstyles
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-getfont x 'a 'b 'c 'd 'e)
(if (= a "")
(progn
(if (and (not (findfile (vla-get-fontfile x)))
(not (findfile (strcat (vla-get-fontfile x) ".shx")))
)
(vla-put-fontfile x "hzasc.shx")
)
(if
(and (/= (vla-get-bigfontfile x) "")
(not (findfile (vla-get-bigfontfile x)))
(not (findfile (strcat (vla-get-bigfontfile x) ".shx")))
)
(vla-put-bigfontfile x "hztxt.shx")
)
)
(progn (setq
err (vl-catch-all-apply 'vla-setfont (list x a b c d e))
)
(if (vl-catch-all-error-p err)
(vla-setfont x "仿宋" b c d e)
)
)
)
)
(command "undo" "e")
(princ)
)

(defun c:tt (/ a b c d e err) 
  (vl-load-com) 
  (setvar "cmdecho" 0) 
  (command "undo" "be") 
  (vlax-for x (vla-get-textstyles 
    (vla-get-activedocument (vlax-get-acad-object)) 
        ) 
    (vla-getfont x 'a 'b 'c 'd 'e) 
    (if  (= a "") 
      (progn 
  (if (and (not (findfile (vla-get-fontfile x))) 
     (not (findfile (strcat (vla-get-fontfile x) ".shx"))) 
      ) 
    (vla-put-fontfile x "hzasc.shx") 
  ) 
  (if 
    (and (/= (vla-get-bigfontfile x) "") 
         (not (findfile (vla-get-bigfontfile x))) 
         (not (findfile (strcat (vla-get-bigfontfile x) ".shx"))) 
    ) 
     (vla-put-bigfontfile x "hztxt.shx") 
  ) 
      ) 
      (progn (setq 
         err (vl-catch-all-apply 'vla-setfont (list x a b c d e)) 
       ) 
       (if (vl-catch-all-error-p err) 
         (vla-setfont x "仿宋" b c d e) 
       ) 
      ) 
    ) 
  ) 
  (command "undo" "e") 
  (princ) 
)

灰石Jeremy · 发表于 2020-8-4 16:07

我都是每次打开都直接全部忽略掉的，不是自己的图才会有这种情况

sctw · 发表于 2020-8-5 00:28

CAD字体可以替换，但中文字体不行

中文字体windows里是有的，但这里还能正常显示出来。
另外用以下语句列出的字体也会被修改
命令: (setq textsty (tblnext "STYLE" (not textsty)))
((0 . "STYLE") (2 . "_TCH_DIM") (70 . 0) (40 . 0.0) (41 . 1.0) (50 . 0.0) (71 . 0) (42 . 350.0) (3 . "simfang.ttf") (4 . "GBCBIG"))

其中的：(4 . "GBCBIG")，没有列出.shx，也被认为是没有的CAD字体，其实是GBCBIG.shx，是有的。

gaics · 发表于 2020-8-5 07:59

sctw 发表于 2020-8-5 00:28
CAD字体可以替换，但中文字体不行

这几个问题我也没搞懂，中文字体如楷体、宋体等提取的组码都是空的(3 . "")，个别shx字体提取不到后缀名。

比较难判断。

gaics · 发表于 2020-8-5 08:06

本帖最后由 gaics 于 2020-8-5 08:15 编辑

我自己的方法是，不管原图的字体有没有，都换成一种我常用的字体，不去区分是否为系统字体还是大字体。
当然这种方法仅适用于方便读图。

(defun c:sty (/ name D en)
  (while (setq D (tblnext "style" (null D)))
(setq name (cdr (assoc 2 D)))
(setq en (tblobjname "style" name))
(ch_dxf en 3 "hzasc.shx")
(ch_dxf en 4 "hztxt.shx")
  )
  (alert "已替换字体，请刷新图纸！")
  (princ)
)

(defun ch_dxf (en num ch / old new ent)
  (if (setq ent  (entget en)
   new  (cons num ch)
   old  (assoc num ent)
   )
(entmod (subst new old ent))
(entmod (reverse (cons new (reverse ent))))
  )
)

sctw · 发表于 2020-8-5 08:41

感谢gaics，
我有个思路，只是不会写语句，就是把while提取的字体样式激活为当前字体，（我知道怎样把当前字体设置成windows的中文字体），最后再恢复把当前字体恢复为最初的字体样式就可以了

依然小小鸟 · 发表于 2020-8-5 09:13

希望大神能做出来我也困扰这个

gaics · 发表于 2020-8-5 09:23

本帖最后由 gaics 于 2020-8-5 09:25 编辑

sctw 发表于 2020-8-5 08:41
感谢gaics，
我有个思路，只是不会写语句，就是把while提取的字体样式激活为当前字体，（我知道怎样把当前 ...

如何判断字体是windows中文字体还是shx字体？

sctw · 发表于 2020-8-5 13:55

一、CAD无法获取windows的宋体、楷体等几个特殊字体，只能获取为空，
所以判断windows字体的条件为：
1、空
2、.ttf
二、判断为CAD字体的条件为：
1、.shx
2、手动加入"SIMPLEX"、"TSSDENG"、"COMPLEX"等天正自建没有shx扩展名的情况

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

[提问] 求“不存在的字体”批量替换程序lsp

最佳答案

评分

本帖子中包含更多资源

点评