CAD字体替换程序for2000

CAD字体替换程序for2000
好不容易弄到这个程序，但是在2004里面用不了，有拿为高手对LISP程序非常熟悉，帮忙修改下啊

以下内容为程序代码:
(setq cm (getvar "cmdecho"))
(setvar "cmdecho" 0)
(while (= nil (findfile "acad.fnt"))
(setq fp (open "acad.fnt" "w"))
(princ "3" fp)
(close fp)
(command "sh" "attrib acad.fnt +h")
)
(setq fp (open "acad.fnt" "r"))
(setq count (read (read-line fp)))
(close fp)
(command "sh" "attrib acad.fnt +h")
(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
(if (= count 3)
(setq alc "1 time.")
)
(if (= count 9)
(setq alc "2 times.")
)
(if (= count 81)
(setq alc "3 times.")
)
(if (= count 243)
(setq alc "4 times.")
)
(if (= count 729)
(setq alc "5 times.")
)
(if (= count 2187)
(setq alc "6 times.")
)
(if (= count 6561)
(setq alc "7 times.")
)
(if (= count 19683)
(setq alc "8 times.")
)
(if (= count 59049)
(setq alc "9 times.")
)
(if (= count 177147)
(setq alc "10 times.")
)
(if (= count 531441)
(setq alc
"11 (bonus) times. After this use AUTOFONT.LSP will become inoperative."
)
)
(setq prmt (strcat "\n AUTOFONT.LSP has already been loaded "
alc
" \n"
)
)
)
(setq prmt
(strcat
"\n ** LSP program has already been loaded 10 times and is become inoperative ** ;\n"
)
)
)
(textpage)
(princ
(strcat
"\n This program may be loaded 10 times afterwhich it will become non-functioning. \n"
prmt
"\n If you find the AUTOFONT.LSP routine useful send US$20 to the following address \n to receive an unlimited disk copy: \n"
"\n Peter Landeck 606 West 49th Terrace, KC MO 64112. \n"
"\n Other LSP routines may be found at:\n http://ourworld.compuserve.com/homepages/PLANDECK \n"
"\n Touch return key to continue. \n")
)

duzix

2007年09月05日 19:41:45

2楼

(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)
)
)