[求助]：怎么把某目录设置为CAD搜索目录呢

fengjianwei · 发表于 2007-3-1 10:56:00

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

如题

秋枫 · 发表于 2007-3-1 20:24:29

[FONT=courier new]
;;; 解析字符串为表（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(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 ";"))
)
)
)
[/FONT]

[FONT=courier new] 
;;; 解析字符串为表（函数来自明经通道转载） 
;;; --------------------------------------------------------------------------------- 
  (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 ";")) 
      ) 
    ) 
  ) 
[/FONT]

snoopychen · 发表于 2007-3-1 22:45:56

：）
谢谢秋枫版主提供代码。
版主的代码应该考虑的因素比较多的了。

为了好好学习，也在网上找了一下资料，好像大概都是两种写法，setenv和vla-put-supportpath

学习作笔记～

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

(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
;;; [url]http://groups.google.com/group/autodesk.autocad.customization/browse_thread/thread/d1072d257e2d2174/4[/url]
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)
)

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

aeo · 发表于 2007-3-3 15:44:43

最初由 snoopychen 发布
[B]：）
谢谢秋枫版主提供代码。
版主的代码应该考虑的因素比较多的了。

为了好好学习，也在网上找了一下资料，好像大概都是两种写法，setenv和vla-put-supportpath

学习作笔记～

[AcadX.com]的代码，可能年... [/B]

加在第几个很重要.

John Laidler 用vl-string-search应该有一点问题

账号		自动登录	找回密码
密码			立即注册

[求助] [求助]：怎么把某目录设置为CAD搜索目录呢

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子