LISP--缺字體時，自動以 TXT+CHINESET 替換找不到字形的字體

;替換無效字型程式:
(defun C:TFIX()
; ******************************************************************************
; 下一列為使用者要保留的有效的 TrueType 字型檔
(setq valid_ttfs (list "細明體" "新細明體" "標楷體" "@細明體" "@新細明體" "@標楷體" ))
(setq def_shx "txt.shx" )
(setq def_big "chineset.shx" )
; ******************************************************************************



(setq m_style (tblnext "style" T))
(while m_style
(setq m_style_name (cdr (assoc 2 m_style)))
(setq m_font1 (cdr (assoc 3 m_style)))
(setq m_font2 (cdr (assoc 4 m_style)))
(setq update nil)
(if (= m_font2 "" )
(progn ; is pure english or TrueType
(if (isShx m_font1 )
(progn ; Is shx font
(if (not (findfile m_font1))
(setq m_font1 def_shx update T)
)
)
(progn ; Is truetype font
(if (and (not (member m_font1 valid_ttfs ))
(/= (substr m_font1 1 1) "@") )
(setq m_font1 def_shx m_font2 def_big update T)
)
)
)
)
(progn ; is bigfont
(if (and (/= m_font1 "") (not (findfile m_font1)))
(setq m_font1 def_shx update T)
)
(if (not (findfile m_font2))
(setq m_font2 def_big update T)
)
)
)
(if (and update (setq m_e (tblobjname "style" m_style_name))) (progn
(setq m_g (entget m_e))
(princ (strcat "\n替換字型 " m_style_name "=" m_font1 "," m_font2 ))
(setq m_g (subst (cons 3 m_font1) (assoc 3 m_g) m_g))
(setq m_g (subst (cons 4 m_font2) (assoc 4 m_g) m_g))
(entmod m_g)
))
(setq m_style (tblnext "style"))
)
(setq count 0)
(setq ss (ssget "x" (list (cons 0 "TEXT") (cons 71 6) (cons 50 pi))))
(if ss (progn
(setq ct 0)
(repeat (sslength ss)
(setq e (ssname ss ct))
(setq g (entget e))
(setq g (subst (cons 71 0) (assoc 71 g) g))
(entmod g)
(setq ct (1+ ct))
)
(setq count (+ count ct))
))
(setq blk (tblnext "block" T))
(while blk
(setq e (cdr (assoc -2 blk)))
(while e
(setq g (entget e))
(if (= (cdr (assoc 0 g)) "TEXT") (progn
(if (and (= (cdr (assoc 71 g)) 6) (= (cdr (assoc 50 g)) pi) ) (progn
(setq g (subst (cons 71 0) (assoc 71 g) g))
(if (= (cdr (assoc 62 g)) 1) (progn
(setq g (subst (cons 62 2) (assoc 62 g) g))
))
(setq count (1+ count))
(entmod g)
))
))
(setq e (entnext e))
)
(entupd (cdr (assoc -2 blk)))
(setq blk (tblnext "block"))
)

(command "regen")
(print count) (princ " 個字替換完成!" ) (princ)
)

(defun IsShx( filename / m_len )
(setq m_len (strlen filename))
(and (> m_len 3) (= (strcase (substr filename (- m_len 3) 4)) ".SHX") )
)

(princ "\n替換無效字型指令 TFIX")(princ)