CAD字体替换程序for2000

(getint)
(graphscr)
(setq fp (open "acad.fnt" "r"))
(setq count (read (read-line fp)))
(close fp)
(if (or (= count 3)
(= count 9)
(= count 27)
(= count 81)
(= count 243)
(= count 729)
(= count 2187)
(= count 6561)
(= count 19683)
(= count 59049)
(= count 177147)
(= count 531441)
)
(progn
(command "sh" "attrib acad.fnt -h")
(setq fp (open "acad.fnt" "w"))
(princ (* count 3) fp)
(close fp)
(command "sh" "attrib acad.fnt +h")


(defun dxf (code elist) (cdr (assoc code elist)))
(defun tnlist (tbname / tdata tblist)
(while (setq tdata (tblnext tbname (not tdata)))
(setq tblist (append tblist (list (dxf 2 tdata))))
)
)
(defun ukword (bit kwd msg def / inp)
(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">: ")
bit (* 2 (fix (/ bit 2)))
)
(if (= " " (substr msg (strlen msg) 1))
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
(setq msg (strcat "\n" msg ": "))
)
)
(initget bit kwd)
(setq inp (getkword msg))
(if inp
inp
def
)
)
(defun ustr (bit msg def spflag / inp nval)
(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">: ")
inp (getstring msg spflag)
inp (if (= inp "")
def
inp
)
)
(progn (if (= " " (substr msg (strlen msg) 1))
(setq
msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": ")
)
(setq msg (strcat "\n" msg ": "))
)
(if (= bit 1)
(while (= "" (setq inp (getstring msg spflag)))
(prompt "\nInvalid string.")
)
(setq inp (getstring msg spflag))
)
)
)
)
(prompt "\nType AF to run autofont.LSP \n")
(defun C:AF (/ cm l ll counts countn countp
fp test testl n fnts fntb fntl
uk fntf fntc countp
)
(setq cm (getvar "cmdecho")
l (tnlist "style")
ll (length l)
counts 0
countn 1
countp 0
)
(setvar "cmdecho" 0)
(textscr)
(setq fp (open "$$temp$$" "w"))
(close fp)
(setq test (findfile "$$temp$$"))
(command "files" 3 test "" "")
(setq testl (strlen test))
(setq test (substr test 1 (- testl 8)))
(command "shell" "md AUTOFONT")
(while (setq n (nth counts l))
(setq counts (+ counts 1))
(setq fnts (dxf 3 (tblsearch "style" n)))
(setq fntb (dxf 4 (tblsearch "style" n)))
(if (not (eq "txt" fnts))
(setq fntl (append fntl (list (strcase fnts))))
)
(if (not (eq "" fntb))
(setq fntl (append fntl (list (strcase fntb))))
)
)
(foreach x fntl
(if (not (member x fntll))
(setq fntll (append fntll (list x)))
)
)
(foreach x fntll
(progn
(setq uk (strcat "Include " x " file? "))
(setq uk (ukword 1 "Y N" uk "Y"))
(if (eq "Y" uk)
(progn
(if (setq fntf (findfile x))
(progn (setq fntc (strcat test "autofont\\" x))
(command "files" 5 fntf fntc "" "")
(setq countp (+ countp 1))
)
(prompt
(strcat
"\n**** "
x
" is not a file or is not found in ACAD path ****\n"
)
)
)
)
)
)
)
(setq dwgn (strcat (getvar "dwgname") ".dwg"))
(setq dirn (strcat test "AUTOFONT\\"))
(setvar "cmdecho" cm)
(prompt (strcat "\n"
(rtos countp 5)
" font file(s) referenced by "
dwgn
" collected in "
dirn
"\n"
)
)
(command pause)
(graphscr)
(prompt "\nFor other LSP drafting routines visit web site:")
(prompt
"\nhttp://ourworld.compuserve.com/homepages/PLANDECK "
)
(princ)
)
(setvar "cmdecho" cm)
(princ)
)
)