在打开图纸时自动替换未找到字体为指定字体的函数

chg

以前在论坛上看到过一个自动替换字体的帖子，受益匪浅，但源程序有些BUG，经自己更改并实验了一段时间，觉得有所进步，现贴出源代码，大家共享，共同改进。函数功能：在打开图纸时，将未能找到的字体文件，用指定的字体文件替代，如果是大字体文件未找到，直接取消大字体，并用指定字体替代。如果大字体文件存在，而字体文件不存在，则用SIMPLEX.SHX作为默认字体替代。
代码如下：

2. (defun auto-ch-style
   
3.        (newztname / st-name zt-name dzt-name st-list textname textfont zt-oldname)
   
4.   (setsysvar)
   
5.   (setvar "cmdecho" 0)
   
6.   (chg_undo_push)
   
7.   (setq st-list nil)
   
8. ;;;在字体样式表中查找出每个字体样式的名称
   
9.   (while (setq st-list (tblnext "STYLE" (null st-list)))
   
10.     (setq st-name  (cdr (assoc 2 st-list)) ;字体样式名称
    
11.           zt-name  (cdr (assoc 3 st-list)) ;字体名称
    
12.           dzt-name (cdr (assoc 4 st-list)) ;大字体名称
    
13.     )
    
14.     (if (= (length (vl_brkstr zt-name "." 0 "")) 1)
    
15.           (setq zt-name (strcat zt-name ".shx"))
    
16.         )
    
17.         ;;;如果字体名称为无则将它命名为新字体
    
18.         (if (= zt-name "")
    
19.           (progn
    
20.             (setq zt-oldname zt-name)
    
21.             (setq zt-name newztname)
    
22.             )
    
23.           (progn
    
24.             (if (/= dzt-name "")
    
25.               (if (not (findfile zt-name))
    
26.                 (setq zt-name "simplex.shx"
    
27.                       zt-oldname 1)
    
28.                 )
    
29.               )
    
30.             )
    
31.                
    
32.         )
    
33.     (if (= dzt-name "")
    
34.       (progn
    
35.         (if (or (findfile zt-name) (dos_find (strcat "c:/windows/fonts/" zt-name)))
    
36.           ;判断是否是程序命名的字体，如是则更改为此字体
    
37.           (if (= zt-oldname "")
    
38.                   (style-change st-name newztname)
    
39.                   )
    
40.           ;未找到字体文件
    
41.           (style-change st-name newztname)
    
42.           )
    
43.         )
    
44.       (progn
    
45.         (if (findfile dzt-name)
    
46.           (progn
    
47.             (if (or (findfile zt-name) (dos_find (strcat "c:/windows/fonts/" zt-name)))
    
48.               (if (= zt-oldname "")
    
49.                   (style-change st-name newztname)
    
50.                   )
    
51.               (progn
    
52.                 (style-change st-name "simplex.shx")
    
53.                 )
    
54.               )
    
55.             )
    
56.           (progn
    
57.             (setq stlist (style-change st-name newztname))
    
58.             ;将大字体取消
    
59.             (entmod (subst (cons 4 "") (assoc 4 stlist) stlist))
    
60.             )
    
61.           )
    
62.         )
    
63.       )
    
64.     )
    
65.   (command "_.regen")
    
66.   (chg_undo_pop)
    
67.   (setsysvar)
    
68.   (setvar "cmdecho" 1)
    
69.   (princ)
    
70. )
    
71. 
    
72. 
    
73. 
    
74. ;;;参数说明：st-name字体样式名称，newztname新的字体名称，须带后缀名
    
75. (defun style-change
    
76.                     (st-name         newztname   /                 ztname
    
77.                      textname         textfont    st-objname         stlist
    
78.                     )
    
79. 
    
80.   (if (null
    
81.         (setq textname
    
82.                (car
    
83.                  (reverse (dos_find (strcat "c:/windows/fonts/" newztname)))
    
84.                )
    
85.         )
    
86.       )
    
87.     (setq textname (findfile newztname))
    
88.   )
    
89. 
    
90.   (if textname
    
91.     (setq textfont (car (reverse (vl_brkstr textname "\" "0" ""))))
    
92.     (progn
    
93.       (princ "/n指定的替代字体未找到，将用楷体替代")
    
94.       (setq textfont "simkai.ttf")
    
95.     )
    
96.   )
    
97. 
    
98.   (if  (vl-string-position (ascii "|") st-name 0 t)
    
99.     (progn                                ;(setq st-list (tblsearch "STYLE" "TEXT-ST"))
    
100.       (setq st-objname (tblobjname "STYLE" st-name))
     
101.       (Setq stlist (entget st-objname))
     
102.       (entmod (subst (cons 3 textfont) (assoc 3 stlist) stlist))
     
103.     )
     
104.     (progn
     
105.       (cond
     
106.         ((= (strcase textfont) "SIMFANG.TTF")
     
107.          (setq textfont "仿宋")
     
108.          )
     
109.         ((= (strcase textfont) "SIMSUN.TTF")
     
110.          (setq textfont "宋体")
     
111.          )
     
112.         ((= (strcase textfont) "SIMKAI.TTF")
     
113.          (setq textfont "楷体")
     
114.          )
     
115.         ((= (strcase textfont) "SIMSUN.TTC")
     
116.          (setq textfont "宋体")
     
117.          )
     
118.         ((= (strcase textfont) "SIMHEI.TTC")
     
119.          (setq textfont "黑体")
     
120.          )
     
121.         )
     
122.       (command "_.-style" st-name textfont "0" "0.7" "0" "n" "n")
     
123.       (if (= (getvar "cmdactive") 1)
     
124.         (command "n")
     
125.       )
     
126.     )
     
127.   )
     
128. )

(defun auto-ch-style<br />        (newztname / st-name zt-name dzt-name st-list textname textfont zt-oldname)<br />   (setsysvar)<br />   (setvar "cmdecho" 0)<br />   (chg_undo_push)<br />   (setq st-list nil)<br /> ;;;在字体样式表中查找出每个字体样式的名称<br />   (while (setq st-list (tblnext "STYLE" (null st-list)))<br />     (setq st-name  (cdr (assoc 2 st-list)) ;字体样式名称<br />           zt-name  (cdr (assoc 3 st-list)) ;字体名称<br />           dzt-name (cdr (assoc 4 st-list)) ;大字体名称<br />     )<br />     (if (= (length (vl_brkstr zt-name "." 0 "")) 1)<br />           (setq zt-name (strcat zt-name ".shx"))<br />         )<br />         ;;;如果字体名称为无则将它命名为新字体<br />         (if (= zt-name "")<br />           (progn<br />             (setq zt-oldname zt-name)<br />             (setq zt-name newztname)<br />             )<br />           (progn<br />             (if (/= dzt-name "")<br />               (if (not (findfile zt-name))<br />                 (setq zt-name "simplex.shx"<br />                       zt-oldname 1)<br />                 )<br />               )<br />             )<br />                 <br />         )<br />     (if (= dzt-name "")<br />       (progn<br />         (if (or (findfile zt-name) (dos_find (strcat "c:/windows/fonts/" zt-name)))<br />           ;判断是否是程序命名的字体，如是则更改为此字体<br />           (if (= zt-oldname "")<br />                   (style-change st-name newztname)<br />                   )<br />           ;未找到字体文件<br />           (style-change st-name newztname)<br />           )<br />         )<br />       (progn<br />         (if (findfile dzt-name)<br />           (progn <br />             (if (or (findfile zt-name) (dos_find (strcat "c:/windows/fonts/" zt-name)))<br />               (if (= zt-oldname "")<br />                   (style-change st-name newztname)<br />                   )<br />               (progn<br />                 (style-change st-name "simplex.shx")<br />                 )<br />               )<br />             )<br />           (progn<br />             (setq stlist (style-change st-name newztname))<br />             ;将大字体取消<br />             (entmod (subst (cons 4 "") (assoc 4 stlist) stlist))<br />             )<br />           )<br />         )<br />       )<br />     )<br />   (command "_.regen")<br />   (chg_undo_pop)<br />   (setsysvar)<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )<br /> <br /> <br /> <br /> ;;;参数说明：st-name字体样式名称，newztname新的字体名称，须带后缀名<br /> (defun style-change<br />                     (st-name         newztname   /                 ztname<br />                      textname         textfont    st-objname         stlist<br />                     )<br /> <br />   (if (null<br />         (setq textname<br />                (car<br />                  (reverse (dos_find (strcat "c:/windows/fonts/" newztname)))<br />                )<br />         )<br />       )<br />     (setq textname (findfile newztname))<br />   )<br /> <br />   (if textname<br />     (setq textfont (car (reverse (vl_brkstr textname "\" "0" ""))))<br />     (progn<br />       (princ "/n指定的替代字体未找到，将用楷体替代")<br />       (setq textfont "simkai.ttf")<br />     )<br />   )<br /> <br />   (if  (vl-string-position (ascii "|") st-name 0 t)<br />     (progn                                ;(setq st-list (tblsearch "STYLE" "TEXT-ST"))<br />       (setq st-objname (tblobjname "STYLE" st-name))<br />       (Setq stlist (entget st-objname))<br />       (entmod (subst (cons 3 textfont) (assoc 3 stlist) stlist))<br />     )<br />     (progn<br />       (cond<br />         ((= (strcase textfont) "SIMFANG.TTF")<br />          (setq textfont "仿宋")<br />          )<br />         ((= (strcase textfont) "SIMSUN.TTF")<br />          (setq textfont "宋体")<br />          )<br />         ((= (strcase textfont) "SIMKAI.TTF")<br />          (setq textfont "楷体")<br />          )<br />         ((= (strcase textfont) "SIMSUN.TTC")<br />          (setq textfont "宋体")<br />          )<br />         ((= (strcase textfont) "SIMHEI.TTC")<br />          (setq textfont "黑体")<br />          )<br />         )<br />       (command "_.-style" st-name textfont "0" "0.7" "0" "n" "n")<br />       (if (= (getvar "cmdactive") 1)<br />         (command "n")<br />       )<br />     )<br />   )<br /> )

字符分割函数

2. (defun vl_brkstr (string   pattern
   
3.                   ctrl1           ctrl2
   
4.                   /           ps
   
5.                   strl           str1
   
6.                   string   str2
   
7.                   brstring str2
   
8.                   )
   
9. ;ctrl1表示是否要将字符串变成大写，0大小写不变，1变成小写，2变成大写；ctrl2表示
   
10. ;是否要去除分割符pattern,当为“Y”时保留，为其他字符时去除。
    
11.   (setq        strl   (strlen pattern)
    
12.         string (strcat string pattern)
    
13.         )
    
14.   (if (/= pattern "")
    
15.     (progn
    
16.       (while (setq ps (vl-string-search pattern string))
    
17.         (if (/= ps 0)
    
18.           (setq        str1   (substr string 1 ps)
    
19.                 str2   str1
    
20.                 string (substr string (+ ps strl 1))
    
21.                 )
    
22.           (if (= (strcase ctrl2) "Y")
    
23.             (progn
    
24.               (if (= ctrl1 2)
    
25.                 (setq str1 (strcase pattern))
    
26.                 (setq str1 pattern)
    
27.                 )
    
28.               (setq str2         pattern
    
29.                     string (substr string (+ ps strl 1))
    
30.                     )
    
31.               )
    
32.             (setq str1         nil
    
33.                   string (substr string (+ ps strl 1))
    
34.                   )
    
35.             )
    
36.           )
    
37.         (if str1
    
38.           (progn
    
39.             (cond
    
40.               ((and (= ctrl1 1) (/= ps 0))
    
41.                (setq str1 (strcase str1 t))
    
42.                )
    
43.               ((and (= ctrl1 2) (/= ps 0)) (setq str1 (strcase str1)))
    
44.               ((= ctrl1 0) (setq str1 str1))
    
45.               )
    
46.             (if        (distof str1)
    
47.               (if (= (rtos (distof str1) 2 24) (rtos (atoi str1) 2 24))
    
48.                 (setq str1 (atof str1))
    
49.                 )
    
50.               )
    
51.             (if        (and (= (strcase ctrl2) "Y") (/= str2  pattern))
    
52.               (progn
    
53.               (if (= ctrl1 2)
    
54.                 (Setq pattern1 (strcase pattern))
    
55.                 (setq pattern1 pattern)
    
56.                 )
    
57.               (setq brstring (append brstring (list str1))
    
58.                     brstring (append brstring (list pattern1))
    
59.                     )
    
60.               )
    
61.               (setq brstring (append brstring (list str1)))
    
62.               )
    
63.             )
    
64.           )
    
65.         )
    
66.       (if (and brstring (= (strcase ctrl2) "Y"))
    
67.         (setq brstring (reverse (cdr (reverse brstring))))
    
68.         )
    
69.       brstring
    
70.       )
    
71.     (progn (princ "Partition symbol is wrong.") (princ))
    
72.     )
    
73.   )
    

(defun vl_brkstr (string   pattern<br />                   ctrl1           ctrl2<br />                   /           ps<br />                   strl           str1<br />                   string   str2<br />                   brstring str2<br />                   )<br /> ;ctrl1表示是否要将字符串变成大写，0大小写不变，1变成小写，2变成大写；ctrl2表示<br /> ;是否要去除分割符pattern,当为“Y”时保留，为其他字符时去除。<br />   (setq        strl   (strlen pattern)<br />         string (strcat string pattern)<br />         )<br />   (if (/= pattern "")<br />     (progn<br />       (while (setq ps (vl-string-search pattern string))<br />         (if (/= ps 0)<br />           (setq        str1   (substr string 1 ps)<br />                 str2   str1<br />                 string (substr string (+ ps strl 1))<br />                 )<br />           (if (= (strcase ctrl2) "Y")<br />             (progn<br />               (if (= ctrl1 2)<br />                 (setq str1 (strcase pattern))<br />                 (setq str1 pattern)<br />                 )<br />               (setq str2         pattern<br />                     string (substr string (+ ps strl 1))<br />                     )<br />               )<br />             (setq str1         nil<br />                   string (substr string (+ ps strl 1))<br />                   )<br />             )<br />           )<br />         (if str1<br />           (progn<br />             (cond<br />               ((and (= ctrl1 1) (/= ps 0))<br />                (setq str1 (strcase str1 t))<br />                )<br />               ((and (= ctrl1 2) (/= ps 0)) (setq str1 (strcase str1)))<br />               ((= ctrl1 0) (setq str1 str1))<br />               )<br />             (if        (distof str1)<br />               (if (= (rtos (distof str1) 2 24) (rtos (atoi str1) 2 24))<br />                 (setq str1 (atof str1))<br />                 )<br />               )<br />             (if        (and (= (strcase ctrl2) "Y") (/= str2  pattern))<br />               (progn<br />               (if (= ctrl1 2)<br />                 (Setq pattern1 (strcase pattern))<br />                 (setq pattern1 pattern)<br />                 )<br />               (setq brstring (append brstring (list str1))<br />                     brstring (append brstring (list pattern1))<br />                     )<br />               )<br />               (setq brstring (append brstring (list str1)))<br />               )<br />             )<br />           )<br />         )<br />       (if (and brstring (= (strcase ctrl2) "Y"))<br />         (setq brstring (reverse (cdr (reverse brstring))))<br />         )<br />       brstring<br />       )<br />     (progn (princ "Partition symbol is wrong.") (princ))<br />     )<br />   )<br />

以上函数要用到dos_lib库，请自行安装。

chg

此函数在不同操作系统下失败，比如你在win7下用仿宋字体，在XP下则显示问号，这个不能更改，不知是什么原因。

hnlgy

WIN7的仿宋字体与XP下不同， WIN7的是仿宋， XP的是仿宋_GB2312。

yjr111

支持楼主共享！

chg

wim7和xp的仿宋字体名称是不同，可是都是SIMFANG.TTF，不过程序就是不能正确识别，用style命令会好些，但对外部参照中的字体不能修改，估计加个判断，将外部参照区分开会好些

byghbcx

从注册表中可以找出仿宋与SIMFANG.TTF的映射

ygp820601

楼主，这段程序放在什么地方呢？

chg

放在自启动的ACADDOC.LSP中的s::startup函数下，直接执行函数（auto-ch-style “simfang.ttf”）即可。另，第一段代码中的style-change函数有更改，可以更新下。

chg

因为没某些原因没弄明白，在style-change函数中的(cond ((= (strcase textfont) "SIMFANG.TTF")...)这一段需要自己根据CAD的提示取舍，如果需要输入.TTF或.SHX字体名称，则这段不要。

lingduwx

哎，对于俺们这些菜鸟中的菜鸟就看不懂了，麻烦楼主可不可以做个完整的文件让我们直接加载应用啊，偶不会编LSP,自启动也不知道怎么做，再次麻烦楼主了，偶替我们这些不懂编lsp谢谢楼主了！！！