批量lsp2html(命令test，默认目录c:\a)

原帖在此，七楼
http://www.xdcad.net/forum/showthread.php?postid=3232315#post3232315

(defun c:test (/ direc directree x y direcfile)
 (setq direc (getstring "\nc:\\a:"))
 (if (= direc "") (setq direc "c:\\a"))
 (setq directree (@Folders direc))
 (foreach x directree
   (setq direcfile (qj-directory-only-files x))
   (foreach y direcfile
 
     (if (= (vl-filename-extension y) ".lsp")
   (lsp->html y)
     )
   )
 )
)


;*******************************************************************************************
;* Here is a simple lisp routine to convert a lisp file to html in Visual Lisp format      *
;*******************************************************************************************
(defun html-format (str)
 (vl-string-subst "&lt;" "<" (vl-string-subst "&amp;" "&" str))
)
(defun lsp->html (file /  rf wf t1 str char i f argument)
 ;(setq file (getfiled "Select Lisp File" (getvar "dwgprefix") "lsp" 0)
 (setq    rf (open file "r")
   wf (open (strcat (vl-filename-directory file) "/"
            (vl-filename-base file) ".html"
        ) "w"
      )
 );s
 (write-line (strcat "<title>" (vl-filename-base file) "</title>") wf)
 (write-line "<pre><font face=Fixedsys color=black size=1>" wf)
 (while (setq t1 (read-line rf))
   (setq str ""
     i 1
   )
   (while (<= i (strlen t1))
     (setq word "")
     (while (not (member (setq char (substr t1 i 1))
             '("" " "
              ";" "("
              ")" "\""
             )
         )
        )
   (setq word (strcat word char)
         i (1+ i)
   )
     );w
     (if (= word "")
   (setq word char
         i (+ i (strlen char))
   )
     )
     (if (= word ";")
   (setq str (strcat str "<font color=purple><span style=\"background-color: #C0C0C0\">"
             (html-format (substr t1 (1- i))) "</span></font>"
         )
         i (1+ (strlen t1))
   );s
   (cond
     ((member word '("(" ")"))
       (setq str (strcat str "<font color=red>")
         i (1- i)
       )
       (while (member (setq char (substr t1 i 1))
              '("(" ")")
          )
         (setq str (strcat str char)
           i (1+ i)
         )
       );w
       (setq str (strcat str "</font>")
         f (= (substr t1 (1- i) 1) "(")
       )
     )
     ((= word "\"")
       (setq str (strcat str "<font color=#FF00FF>" word))
       (while (and
            (/= (setq char (substr t1 i 1))
            ""
            )
            (or
              (/= char "\"")
              (and
            (> i 1)
            (= (substr t1 (1- i) 1) "\\")
            (or
              (= i 2)
              (/= (substr t1 (- i 2) 1) "\\")
            )
              )
            )
          )
         (setq str (strcat str (html-format char))
           i (1+ i)
         )
       );w
       (setq str (strcat str char "</font>")
         i (1+ i)
       )
     )
     ((= word "'")
       (setq str (strcat str "<font color=#800000>'</font>"))
     )
     ((= word "/")
       (setq str (strcat str "<font color=blue>/</font>")
         argument nil
         f nil
       )
     )
     ((= word ".")
       (setq str (strcat str word))
     )
     ((numberp (read word))
       (setq str (strcat str "<font color=green>" word "</font>")
         f nil
       )
     )
     (f (if argument
          (setq str (strcat str (html-format word))
            argument nil
            f nil
          )
          (setq str (strcat str "<font color=blue>"
                (html-format word) "</font>"
            )
            argument (= (strcase word) "DEFUN")
            f nil
          )
        )
     );f
     (T
       (setq str (strcat str (html-format word)))
     )
   );c
     );i
   );w
   (write-line str wf)
 );f
 (write-line "</font></pre>" wf)
 (close rf)
 (close wf)
 (princ)
)
;d
(prompt "\nType \"test\" at the command prompt to run routine.")
(princ)
;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN                 ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To get a file list of the currrent path                       ;
;;; The platform: Acad2000 and after                                       ;
;;; 2006.07.12                                                             ;
;;; Http://autolisper.googlepages.com                                      ;
;;; Http://qjchen.googlepages.com                                          ;
;;; ========================================================================
(defun qj-directory-only-files (path / lst res)
 (setq lst (vl-directory-files path))
 (setq lst (mapcar
         '(lambda (x)
        (strcat path "\\" x)
          )
         lst
       )
 )
 (foreach x lst
   (if (not (vl-file-directory-p x))
     (setq res (append
         res
         (list x)
       )
     )
   )
 )
 res
)
;;; ========================================================================
;; given the parent folder as a Path.                                      ;
;; Note that using a path of "" or "." or "\\" will exclude                ;
;; the drive letter.  McNeel's DOSLIB has a DOS_FULLPATH function          ;
;; that can return such folders with drive designations.                   ;
;; (c) John F. Uhden, Cadlantic                                            ;
;;; ========================================================================
(defun @Folders (Path / Folders @Dirs)
 (defun @Dirs (Path / Dir Dirs)
   (and
     (= (type Path) 'STR)
     (or
   (/= (type DOS_FULLPATH) 'EXRXSUBR)
   (setq Path (DOS_FULLPATH Path))
     )
     (if (wcmatch Path ",*/,*\\")
   (setq Dir Path)
   (setq Dir (strcat Path "\\"))
     )
     (setq Dirs (vl-directory-files Dir "*.*" -1))
     (setq Folders (cons Path Folders))
     (setq Dirs (vl-remove-if '(lambda (x)
                 (vl-position x '("." ".."))
               ) Dirs
        )
     )
     (mapcar
   '@Dirs
   (mapcar
     '(lambda (x)
        (strcat Dir x)
      )
     Dirs
   )
     )
   )
 )
 (@Dirs Path)
 (reverse Folders)
)