[分享]：替换图形字体

carrot1983

说明：虽然这个程序好像很多了，但是手痒算灌水吧。。。呵呵

2. 
   
3.   [FONT=courier new]
   
4. ;;修改文字样式的字体
   
5. ;;writen by carrot1983 2008-12-27
   
6. (defun C:TT (/ ELIST FONT V2 V3 V4)
   
7.   (setvar "cmdecho" 0)
   
8.   (command "._undo" "begin")
   
9.   (textscr)
   
10.   (initget 7)
    
11.   (setq FONT "tssdeng.shx,hztxt.shx")
    
12.   (princ (strcat "\n*|*|*|*|*| 字体全部替换成"
    
13.                  FONT
    
14.                  "但不替换宋体 |*|*|*|*|*"
    
15.          )
    
16.   )
    
17.   (princ "\n*****\n*****")
    
18.   (setq ELIST (tblnext "style" t))
    
19.   (while ELIST
    
20.     (setq V2 (cdr (assoc 2 ELIST)))
    
21.     (setq V3 (cdr (assoc 3 ELIST)))
    
22.     (setq V4 (cdr (assoc 4 ELIST)))
    
23.     (if        (/= "SimSun.ttf" V3)                ;非宋体,可以根据需求修改
    
24.       (progn
    
25.         (command ".-style"
    
26.                  V2
    
27.                  FONT
    
28.                  ""
    
29.                  ""
    
30.                  ""
    
31.                  ""
    
32.                  ""
    
33.                  ""
    
34.         )
    
35.         (princ
    
36.           (strcat "\n" V2 ":   [" V3 " " V4 "] " "-> [" FONT "]")
    
37.         )
    
38.       )
    
39.       (princ (strcat "\n" V2 ":   [" V3 "] "))
    
40.     )
    
41.     (setq ELIST (tblnext "style"))
    
42.   )
    
43.   (command "._regen")
    
44.   (princ "\n*****\n*****")
    
45.   (princ
    
46.     "\n*|*|*|*|*| 字体替换完毕 |*|*|*|*|* \n      carrot1983 2008-12-27"
    
47.   )
    
48.   (command "._undo" "begin")
    
49.   (setvar "cmdecho" 1)
    
50.   (princ)
    
51. )
    
52.   [/FONT]
    

<br />   [FONT=courier new]<br /> ;;修改文字样式的字体<br /> ;;writen by carrot1983 2008-12-27<br /> (defun C:TT (/ ELIST FONT V2 V3 V4)<br />   (setvar "cmdecho" 0)<br />   (command "._undo" "begin")<br />   (textscr)<br />   (initget 7)<br />   (setq FONT "tssdeng.shx,hztxt.shx")<br />   (princ (strcat "\n*|*|*|*|*| 字体全部替换成"<br />                  FONT<br />                  "但不替换宋体 |*|*|*|*|*"<br />          )<br />   )<br />   (princ "\n*****\n*****")<br />   (setq ELIST (tblnext "style" t))<br />   (while ELIST<br />     (setq V2 (cdr (assoc 2 ELIST)))<br />     (setq V3 (cdr (assoc 3 ELIST)))<br />     (setq V4 (cdr (assoc 4 ELIST)))<br />     (if        (/= "SimSun.ttf" V3)                ;非宋体,可以根据需求修改<br />       (progn<br />         (command ".-style"<br />                  V2<br />                  FONT<br />                  ""<br />                  ""<br />                  ""<br />                  ""<br />                  ""<br />                  ""<br />         )<br />         (princ<br />           (strcat "\n" V2 ":   [" V3 " " V4 "] " "-> [" FONT "]")<br />         )<br />       )<br />       (princ (strcat "\n" V2 ":   [" V3 "] "))<br />     )<br />     (setq ELIST (tblnext "style"))<br />   )<br />   (command "._regen")<br />   (princ "\n*****\n*****")<br />   (princ<br />     "\n*|*|*|*|*| 字体替换完毕 |*|*|*|*|* \n      carrot1983 2008-12-27"<br />   )<br />   (command "._undo" "begin")<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )<br />   [/FONT]<br />

hsb-hy

楼主好，试用了一下，速度好像很慢，还有就是如果字体文件夹内没有你指定的两个字体文件怎么办？

carrot1983

最初由 hsb-hy 发布
[B]楼主好，试用了一下，速度好像很慢，还有就是如果字体文件夹内没有你指定的两个字体文件怎么办？ [/B]

那就修改
(setq FONT "tssdeng.shx,hztxt.shx")
这个东西。。。
tssdeng.shx
hztxt.shx
中间隔着逗号。。。

至于速度慢，是因为用了command。

以下程序可以试试，会快些。。。
但是我自己试了没反应。
谁试用了能用，回个帖。
[php]
(defun C:ZT ()
  (graphscr)
  (initget 7)
  (setq A1 (tblnext "style" t)) ;_将指针移到第一个字体
  (while A1
    (setq A2 (cdr (assoc 2 A1))) ;_取出字体名称
    (setq A3 (entget (tblobjname "style" A2))) ;_取出字体的数据串行
    (setq A3 (subst (cons 3 "Tssdeng.shx") (assoc 3 A3) A3)) ;_将字体字型改成新字型

    (entmod A3) ;_更新字体
    (setq A3 (subst (cons 4 "Tssd.shx") (assoc 4 A3) A3)) ;_将字体字型改成新字型

    (entmod A3) ;_更新字体
    (setq A1 (tblnext "style")) ;_找出下一个字体
  )
  (command "REGEN" "")
  (princ "字型变更成功！现在字体为Tssdeng.shx")
  (princ)
)
[/php]