刚好xd论坛有这个问题，秋枫版主也做了回答，为了好好学习，也在网上找了一下其他资料，好像大概都是两种写法，setenv和vla-put-supportpath，其实记得有一个专门讨论preference里面操作的，现在不明确的是否所有的vba都能被lisp支持。
Lisp是一个很奇怪的语言，好像不同人会写出各式各样的代码，但是有时候高手的代码又会几乎一模一样。好奇怪。
学习作笔记～
秋枫兄代码:
;;; 解析字符串为表（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
) ;_ end of while
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq SearchStr (substr SearchStr (1+ n) StringLen))
(setq StringLen (strlen SearchStr))
) ;_ end of while
(reverse return)
) ;_ end of defun
;;; 反解析表为字符串（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst
(setq return (strcat return Delimiter str))
) ;_ end of foreach
(substr return 2)
) ;_ end of defun
;;; 添加支持文件搜索路径
;;; ---------------------------------------------------------------------------------
;;; note: 第二个参数如果为真, 插最前，否则插最后
;;;
(defun AddSupportPath (PathToAdd isFirst / supportlist)
(if (not
(vl-string-search
(strcase (strcat pathToAdd ";"))
(strcase (strcat (getenv "ACAD") ";"))
)
) ; 保证不重复添加
(progn
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist
(vl-remove-if-not
'vl-file-directory-p
supportlist
)
) ; 移除不存在的文件夹
(if isFirst
(setq supportlist (cons PathToAdd supportlist))
(setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
)
)
[AcadX.com]的代码，可能年代也挺久的，和秋枫版主的类似
代码:
(defun addSP (dir pos / tmp c lst)
(setq tmp ""
c -1
)
(if (not (member (strcase dir) (setq lst (mapcar
'strcase
(parse (getenv "ACAD") ";")
)
)
)
)
(progn
(if (not pos)
(setq tmp (strcat (getenv "ACAD") ";" dir))
(mapcar
'(lambda (x)
(setq tmp (if (= (setq c (1+ c))
pos
)
(strcat tmp ";" dir ";" x)
(strcat tmp ";" x)
)
)
)
lst
)
)
(setenv "ACAD" tmp)
)
)
(princ)
)
(defun parse (str delim / lst pos)
(setq pos (vl-string-search delim str))
(while pos
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 2))
pos (vl-string-search delim str)
)
)
(if (> (strlen str) 0)
(setq lst (cons str lst))
)
(reverse lst)
)
; Arguments : A folder path and the position at which to insert it. (0 based.)
; Here's an example to add a support folder :
(addSP "c:\\afralisp" 3)
John Laidler ，也用setenv函数，没有选择位置项
代码:
;;; John Laidler
;;; http://groups.google.com/group/auto...72d257e2d2174/4
b0851cbad83d142?lnk=gst&q=add+support+path&rnum=4#4b0851cbad83d142
(defun CS:AddSupportPath (dir / tmp Cpath)
(vl-load-com)
(setq Cpath (getenv "ACAD")
tmp (strcat ";" dir ";")
)
(if (not (vl-string-search dir cpath))
(setenv "ACAD" (strcat Cpath ";" dir))
)
(princ)
)
(CS:ADDSUPPORTPATH "c:\\b")
下面三个是theswamp找到的函数
MP，只用一句话，是vla函数
代码:
;;;[MP]
(defun _AddSupportPath ( path / files )
(vla-put-supportpath
(setq files
(vla-get-files
(vla-get-preferences
(vlax-get-acad-object)
)
)
)
(strcat
(vla-get-supportpath files) ";"
path
)
)
)
(_addsupportpath "c:\\3")
Jeff_M和kerry Brown都是为了一个问题写的，希望一次加多个子目录
代码:
(defun c:ldp (/ FilePrefs addEnviron EnvironBase acadEnviron)
(setq FilePrefs (vla-get-files (vla-get-preferences
(vlax-get-acad-object)
)
)
)
(setq acadEnviron (vla-get-supportpath FilePrefs))
(setq EnvironBase "M:\\_Cad Support\\AutoCAD 2004\\2004dannyCAD\\MENU\\")
(setq addEnviron '("Area" "Blocks"
"Dimensions" "Layers"
"Linetypes" "Plotting"
"Settings" "Shortcuts"
"Text"
);;;add any others you want to this list
)
(if (not (vl-string-search (strcat EnvironBase (car addEnviron))
acadEnviron
);;;make sure we haven't already done this
)
(progn
(mapcar
'(lambda (x)
(setq acadEnviron (strcat acadEnviron ";" EnvironBase x))
)
addEnviron
)
(vla-put-supportpath FilePrefs acadEnviron)
(princ "\n....Support Paths updated!")
);progn
(princ "\n....Support Paths were previously updated...nothing done.")
);if
(princ)
)
Kerry Brown
代码:
(VL-LOAD-COM)
(prompt "\n <> Load Dependant Support Paths to profile [V0.01]")
(defun c:LDP (/ fileprefs addenviron environbase acadenviron)
(setq fileprefs (vla-get-files (vla-get-preferences
(vlax-get-acad-object)
)
)
)
(setq acadenviron (vla-get-supportpath fileprefs))
(setq environbase "M:\\_Cad Support\\AutoCAD 2004\\2004dannyCAD\\MENU\\")
(setq addenviron '("Area" "Blocks"
"Dimensions" "Layers"
"Linetypes" "Plotting"
"Settings" "Shortcuts"
"Text"
)
)
(mapcar
'(lambda (x)
(setq acadenviron (strcat acadenviron ";" environbase x))
)
addenviron
)
(vla-put-supportpath fileprefs acadenviron)
(PRINC)
)
