[LISP函数]：autofont程序源代码,高手来改正适用现版本

linsankai

格式有点乱不要介意，复制到编辑器里排版就好了.
程序已经解密，里面还有10次数使用限制(这个加密有点意思好玩)，去掉后就是主程序，但是问题是这个程序太老了，command 后面还在用file命令，是哪个版本的哦，高手来看看，怎么改改。这个用处我感觉还是很大的，把图中用到的shx字体复制到图形目录下建立的autofont目录里面。
(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"))(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)))

它山之石

1、这个问题已经N多讨论。楼主可以搜索一下。
2、这程序请大家放弃吧。新版本的CAD已经有这个功能。
3、最后一次将俺N久前修改的能用的程序贴上。
[php]
;;;    =============================================
;;;    |            自动提取图中字体软件           |
;;;    |              Update: 03.06.12             |
;;;    =============================================




;;;以下内容定义程序加载时提示加载次数、版权等信息


;;;(setq cm (getvar "cmdecho"))
;;;(setvar "cmdecho" 0)
;;;(while (= nil (findfile "acad.fnt"))
;;;  ;(setq fp (open "c:\\acad.fnt" "w"))
;;;  ;(setq fp (open "acad.fnt" "w"))
;;;
;;;  ;(write-line "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"
;;;         )
;;;  )
;;;)
;;;(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"))
;;;    (setq aaa (* count 3))
;;;    (princ aaa fp)
;;;    (write-line aaa fp)
;;;
;;;    (close fp)
;;;    (command "sh" "attrib acad.fnt +h")

;;;以下定义从关联表“elist”中搜索含有元素“code”的条目
(defun dxf (code elist) (cdr (assoc code elist)))

;;;以下定义得到所有指定类型“tbname”的集合
(defun tnlist (tbname / tdata tblist)
  (while (setq tdata (tblnext tbname (not tdata)))
    (setq tblist (append tblist (list (dxf 2 tdata))))
  ) ;_ 结束while
) ;_ 结束defun

;;;以下定义得到关键字提示
(defun ukword (bit kwd msg def / inp)
  (if (and def (/= def ""))
    (setq msg (strcat "\n" msg "<" def ">: ")
          bit (* 2 (fix (/ bit 2)))
    ) ;_ 结束setq
    (if        (= " " (substr msg (strlen msg) 1))
      (setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
      (setq msg (strcat "\n" msg ": "))
    ) ;_ 结束if
  ) ;_ 结束if
  (initget bit kwd)
  (setq inp (getkword msg))
  (if inp
    inp
    def
  ) ;_ 结束if
) ;_ 结束defun

;;;    (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
             x            test   testl  n         fnts        fntb   fntl   uk
             fntf   fntc   countp si         sii        stt    fntll
            )
  (princ (strcat "\n***自动提取图中字体软件V031212***"))
  (princ (strcat "\n       [它山之石修正版]"))
  (princ)


  (setq        cm     (getvar "cmdecho")
        l      (tnlist "style")                ;列出本图中定义的所有字体
        ll     (length l)                ;所有的字体数
        counts 0
        countn 1
        countp 0
  ) ;_ 结束setq
  (setvar "cmdecho" 0)
  (command "shell" (strcat "md c:\gelei"))
;;;建立备份字体的文件夹
  (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        (or (eq "txt" fnts) (eq "txt.shx" fnts))
      (setq err 1)
      (setq fntl (append fntl (list (strcase fnts))))
    ) ;_ 结束if
    (if        (not (eq "" fntb))
      (setq fntl (append fntl (list (strcase fntb))))
    ) ;_ 结束if
  ) ;_ 结束while
  (setq fntl (append fntl (list (strcase (getvar "dwgname")))))

  (setq dwgn (findfile (getvar "dwgname")))

  (if err
    (alert
      (strcat
        "\n                     ******  友  情  提  醒  ******"
        "\n\n        本图中使用了“txt.shx”字体，在移动或复制实体时"
        "\n\n可能会导致AutoCAD系统崩溃或其它未可知的致命错误！"
        "\n\n共享版本不提供自动提取该字体文件的功能！"
        "\n\n                                                    ----它山之石") ;_ 结束strcat
    ) ;_ 结束alert
    (setq err nil)
  ) ;_ 结束if
  (foreach x fntl
    (if        (not (member x fntll))
      (setq fntll (append fntll (list x)))
    ) ;_ 结束if
  ) ;_ 结束foreach
  (setq sty (length fntll))
  (foreach x fntll
    (progn
      (if x
        (progn
          (if (findfile x)
            (setq x x)
            (progn
              (if (eq "TTF" (setq qq (substr x (- (strlen x) 2))))
                (progn
                  (alert
                    (strcat
                      "\n                     ******  友  情  提  醒  ******"
                      "\n\n        字体 " x " 可能是WINDOWS的系统字体，"
                      "\n\n使用此类字体会导致图形文件狂大，少用为宜。"
                      "\n\n共享版本不提供自动提取该字体文件的功能！"
                      "\n\n                                                    ----它山之石") ;_ 结束strcat
                  ) ;_ 结束alert
                  (setq ttf 1)
                ) ;_ 结束progn
                (setq x (strcat x ".shx"))
              ) ;_ 结束if
            ) ;_ 结束progn
          ) ;_ 结束if
          (if (setq fntf (findfile x))
            (progn
              (setq fntc " c:\\GELEI\\")

              (setq si 1
                    sii        0
              ) ;_ 结束setq
              (setq txt 1)                ;得到要查找字符串的长度
              (while                        ;在一个被查找字符串中循环查找
                (= txt (strlen (setq st (substr fntf si txt))))
                 (if (or (eq st "\\") (eq st "."))
                                        ;如果查找到相匹配的字符串
                   (setq sii (+ si 1))
                 ) ;_ 结束if
                 (if (> (- si sii) 7)        ;如果查找到相匹配的串
                   (progn
                     (setq stt (substr fntf sii (- si sii)))
                     (setq stt (strcat (substr stt 1 6) "~1"))
                     (setq fntf        (strcat        (substr fntf 1 (- sii 1))
                                        stt
                                        (substr fntf (+ 1 si))
                                ) ;_ 结束strcat
                     ) ;_ 结束setq
                     (setq si (- si sii 8))
                     (command "SHELL"
                              (strcat "XCOPY " fntf fntc " /y")
                     ) ;_ 结束command
                   ) ;_ 结束progn
                 ) ;_ 结束if
                 (setq si (+ 1 si))
              ) ;_ 结束while
              (setq countp (+ countp 1))
            ) ;_ 结束progn
            (progn
              (if ttf
                (setq ttf nil)
                (alert
                  (strcat "\n        在AutoCAD的搜索路径下未找到字体 "
                          x
                          " ，\n"
                          "\n本图可能也无法正确显示使用该字体的文本！\n"
                  ) ;_ 结束strcat
                ) ;_ 结束alert
              ) ;_ 结束if
            ) ;_ 结束progn
          ) ;_ 结束if
        ) ;_ 结束progn
      ) ;_ 结束if
    ) ;_ 结束progn
  ) ;_ 结束foreach

  (command "shell"
           "DIR c:\\GELEI\\*.shx /s/a/B >C:\\GELEI\\GELEI"
  ) ;_ 结束command
  (setq lujing (open "C:\\GELEI\\GELEI" "r"))
                                        ;LUJING--保存带完全路径的文件名
  (setq n 0)
  (while
    (read-line LUJING)
     (setq n (+ n 1))

  )                                        ;WENJIAN--带完全路径的文件名
  (close LUJING)
  (command "shell" "del C:\\GELEI\\GELEI")


  (alert (strcat "\n       本图中共定义了 "
                 (rtos ll 5)
                 " 个文字式样，使用到了"
                 (rtos sty 5)
                 " 个字体文件，\n\n其中"
                 (rtos n 5)
                 "个被提取到了 "
                 "C:\\GELEI 目录下"
         ) ;_ 结束strcat
  ) ;_ 结束alert

  (princ (strcat "\n***自动提取图中字体软件V031212***"))
  (princ (strcat "\n       [它山之石修正版]"))
  (princ)
) ;_ 结束defun

[/php]