干掉选择字体对话框，开图自动替换字体（2021.3.2增加c#版本）

print1985

对不起各位，因最近发现本人发的个别插件、源码被人挂网上贩卖，虽然没啥技术含量，但是也是花了时间做的。为了不被后面的二手贩子继续利用，忍心下架所有成品插件，敬请理解，确实需要本插件的朋友可以给我留言。
请版主把本帖改为普通帖子，对不起了


开图不停的替换字体，囧 囧 囧  受够了，干掉这个讨厌的对话框，自动替换未知字体


1、Lisp文件这里要修改为你想要的字体。


2、CAD菜单-工具-选项-系统-隐藏消息设置


3、勾选如下图


4、打开缺少字体的图纸，如图勾选“始终执行……”，后点击“忽略缺少的……”


搞定，以后开图不会出现选择字体对话框了，lisp程序会在开图后会自动替换未知字体。

主要源码来自http://bbs.mjtd.com/forum.php?mod=viewthread&tid=181963&extra=&highlight=%D7%D6%CC%E5%2B%CC%E6%BB%BB&page=1

我只作了简单修改，感谢gaics、sctw、wudechao等各位大侠

2. ;手动替换字体，命令tzt
   
3. (defun c:tzt() (GL:changefont))
   
4. 
   
5. ;替换字体
   
6. (defun GL:changefont ( / *error* a b c d date1 e err font_chn font_eng font_lst_chn font_lst_eng font_lst_tru font_tru textstyles x)
   
7. (setq font_eng "tssdeng.shx"  ;tssdeng.shx英文字体，自行修改
   
8.       font_chn "tssdchn.shx"  ;tssdchn.shx中文字体，自行修改
   
9.       font_tru "宋体"         ;windows系统字体，自行修改
   
10.       font_lst_eng '()
    
11.       font_lst_chn '()
    
12.       font_lst_tru '()
    
13. )
    
14. 
    
15. (defun *error* (msg) ;错误处理
    
16.   (setvar "regenmode" 1)
    
17.   (command "undo" "e")
    
18.   (setvar "cmdecho" 1)
    
19.   (princ msg)
    
20. )
    
21. 
    
22. (vl-load-com)
    
23. (setvar "cmdecho" 0)
    
24. (command "undo" "be")
    
25. (setvar "regenmode" 0)
    
26. (setq date1 (getvar "millisecs"))
    
27. (setq textstyles (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object))))
    
28. (vlax-for x textstyles (vla-getfont x 'a 'b 'c 'd 'e) (if (= a "")
    
29.                                                         (progn
    
30.                                                          (if (and
    
31.                                                               (not (findfile (vla-get-fontfile x)))
    
32.                                                               (not (findfile (strcat (vla-get-fontfile x) ".shx")))
    
33.                                                              )
    
34.                                                          (progn
    
35.                                                           (vla-put-fontfile x font_eng)
    
36.                                                           (setq font_lst_eng (cons (vla-get-name x) font_lst_eng))
    
37.                                                          )
    
38.                                                          )
    
39.                                                          (if (and
    
40.                                                               (/= (vla-get-bigfontfile x) "")
    
41.                                                               (not (findfile (vla-get-bigfontfile x)))
    
42.                                                               (not (findfile (strcat (vla-get-bigfontfile x) ".shx")))
    
43.                                                              )
    
44.                                                          (progn
    
45.                                                           (vla-put-bigfontfile x font_chn)
    
46.                                                           (setq font_lst_chn (cons (vla-get-name x) font_lst_chn))
    
47.                                                          )
    
48.                                                          )
    
49.                                                         )
    
50.                                                         (progn
    
51.                                                          (setq err (vl-catch-all-apply 'vla-setfont (list x a b c d e)))
    
52.                                                          (if (vl-catch-all-error-p err)
    
53.                                                          (progn
    
54.                                                           (vla-setfont x font_tru b c d e)
    
55.                                                           (setq font_lst_tru (cons (vla-get-name x) font_lst_tru))
    
56.                                                          )
    
57.                                                          )
    
58.                                                         )
    
59.                                                        )
    
60. )
    
61. (setvar "regenmode" 1)
    
62. (command "regen")
    
63. (princ "\n")
    
64. (if (or font_lst_eng font_lst_chn font_lst_tru)
    
65. (progn
    
66.   (princ (strcat "字体替换完成，共耗时" (rtos (/ (- (getvar "millisecs") date1)1000.000) 2 3) "秒。  "))
    
67.   (if font_lst_eng (progn (princ "文字样式：")(princ font_lst_eng)(princ (strcat "的英文字体已替换为" font_eng "。  "))))
    
68.   (if font_lst_chn (progn (princ "文字样式：")(princ font_lst_chn)(princ (strcat "的中文字体已替换为" font_chn "。  "))))
    
69.   (if font_lst_tru (progn (princ "文字样式：")(princ font_lst_tru)(princ (strcat "的字体已替换为" font_tru "。  "))))
    
70. )
    
71. (princ "\n所有字体均存在，未替换")
    
72. )
    
73. (command "undo" "e")
    
74. (setvar "cmdecho" 1)
    
75. (princ)
    
76. )
    
77. 
    
78. ;开图自动替换字体
    
79. (GL:changefont)

;手动替换字体，命令tzt<br /> (defun c:tzt() (GL:changefont))<br /> <br /> ;替换字体<br /> (defun GL:changefont ( / *error* a b c d date1 e err font_chn font_eng font_lst_chn font_lst_eng font_lst_tru font_tru textstyles x)<br /> (setq font_eng "tssdeng.shx"  ;tssdeng.shx英文字体，自行修改<br />       font_chn "tssdchn.shx"  ;tssdchn.shx中文字体，自行修改<br />       font_tru "宋体"         ;windows系统字体，自行修改<br />       font_lst_eng '()<br />       font_lst_chn '()<br />       font_lst_tru '()<br /> )<br /> <br /> (defun *error* (msg) ;错误处理<br />   (setvar "regenmode" 1)<br />   (command "undo" "e")<br />   (setvar "cmdecho" 1)<br />   (princ msg)<br /> )<br /> <br /> (vl-load-com)<br /> (setvar "cmdecho" 0)<br /> (command "undo" "be")<br /> (setvar "regenmode" 0)<br /> (setq date1 (getvar "millisecs"))<br /> (setq textstyles (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object))))<br /> (vlax-for x textstyles (vla-getfont x 'a 'b 'c 'd 'e) (if (= a "")<br />                                                         (progn<br />                                                          (if (and<br />                                                               (not (findfile (vla-get-fontfile x)))<br />                                                               (not (findfile (strcat (vla-get-fontfile x) ".shx")))<br />                                                              )<br />                                                          (progn<br />                                                           (vla-put-fontfile x font_eng)<br />                                                           (setq font_lst_eng (cons (vla-get-name x) font_lst_eng))<br />                                                          )<br />                                                          )<br />                                                          (if (and<br />                                                               (/= (vla-get-bigfontfile x) "")<br />                                                               (not (findfile (vla-get-bigfontfile x)))<br />                                                               (not (findfile (strcat (vla-get-bigfontfile x) ".shx")))<br />                                                              )<br />                                                          (progn<br />                                                           (vla-put-bigfontfile x font_chn)<br />                                                           (setq font_lst_chn (cons (vla-get-name x) font_lst_chn))<br />                                                          )<br />                                                          )<br />                                                         )<br />                                                         (progn<br />                                                          (setq err (vl-catch-all-apply 'vla-setfont (list x a b c d e)))<br />                                                          (if (vl-catch-all-error-p err)<br />                                                          (progn<br />                                                           (vla-setfont x font_tru b c d e)<br />                                                           (setq font_lst_tru (cons (vla-get-name x) font_lst_tru))<br />                                                          )<br />                                                          )<br />                                                         )<br />                                                        )<br /> )<br /> (setvar "regenmode" 1)<br /> (command "regen")<br /> (princ "\n")<br /> (if (or font_lst_eng font_lst_chn font_lst_tru)<br /> (progn<br />   (princ (strcat "字体替换完成，共耗时" (rtos (/ (- (getvar "millisecs") date1)1000.000) 2 3) "秒。  "))<br />   (if font_lst_eng (progn (princ "文字样式：")(princ font_lst_eng)(princ (strcat "的英文字体已替换为" font_eng "。  "))))<br />   (if font_lst_chn (progn (princ "文字样式：")(princ font_lst_chn)(princ (strcat "的中文字体已替换为" font_chn "。  "))))<br />   (if font_lst_tru (progn (princ "文字样式：")(princ font_lst_tru)(princ (strcat "的字体已替换为" font_tru "。  "))))<br /> )<br /> (princ "\n所有字体均存在，未替换")<br /> )<br /> (command "undo" "e")<br /> (setvar "cmdecho" 1)<br /> (princ)<br /> )<br /> <br /> ;开图自动替换字体<br /> (GL:changefont)

----------------------------------c#版本-------------------------------------------
2021.3.2增加c#版本

源码来自 http://blog.sina.com.cn/s/blog_69e8fdf00100nc58.html  版权归原作者所有，感谢！
本人修改了几处代码并重新编译以适应高版本CAD

使用方法：
1、将DLL文件设为自动加载（不会设的设置的可以参看我发的lisp+c#混合编程帖子的lisp代码）。
2、开图使用Hztxt.shx自动替换未知字体，所以你的CAD至少得有Hztxt.shx字体。
3、DLL可以单独使用，也可以和上面的lisp代码组合使用，当然如果要用DLL就不能干掉字体替换对话框了(干掉C#程序就没法自动选择字体了)，不干掉字体选择对话框lisp也是可以自动替换的。

原理：开图出现字体选择对话框时，自动选择Hztxt.shx字体替换未知字体（可以理解为模拟按键，代替手动选择）

杨张张

学习了                  

hh_lj007

谢谢分享！

HLCAD

感谢楼主提供的程序！！！

SHUNDocker

感谢楼主分享学习！！！

aisong220

zc1zc2

6666666666,感谢分享

afrgrgfdgdgt111

谢谢楼主分享

hh_lj007

试试这个，只要电脑中安装了对应的ttf后缀格式字体

print1985

2021.3.2增加c#版本
不喜欢的lisp版本的可以试试C#版

94665169

谢谢分享

print1985

给yanchao316 win10测试用 2个版本 看下有能用的没得

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:ChangeFonts(CAD2012).rar 
下载次数:60  文件大小:3.79 KB 
下载权限: 不限 以上  [免费赚D豆]

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:ChangeFonts CAD2012版本2.rar 
下载次数:28  文件大小:3.73 KB 
下载权限: 不限 以上  [免费赚D豆]

yanchao316

print1985 发表于 2021-3-4 19:08
给yanchao316 win10测试用 2个版本 看下有能用的没得

多谢！测试了，ChangeFonts(CAD2012)已经能在win10下完美运行了。先前的2007～2012又试了，也能运行了。前两天不知道啥原因用不了。

lijoicq1

调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)

print1985

lijoicq1 发表于 2021-3-22 16:12
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command- ...

CAD高版本的问题，替换一下这段

(defun *error* (msg) ;错误处理
  (setvar "regenmode" 1)
  (command-s "undo" "e");高版本用command-s
  (setvar "cmdecho" 1)
  (princ msg)
)