2007年6月4日星期一

批量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)
)