[原创]：新写的一个目录选取函数

hqd9639

写程序时常用到这个函数，而又不想用外挂API，就把它写了下来。

2. 
   
3.   [FONT=courier new]
   
4. (defun HBrowseFolder (msg / index dirlist obj folders path1 dirlist0 path)
   
5.   (if (null msg)
   
6.     (setq msg "Select folder")
   
7.   )
   
8.   (setq index T)
   
9.   (setq dirlist '() path nil)
   
10.   (vl-load-com)
    
11.   (setq obj (vlax-create-object "Shell.Application"))
    
12.   (setq folders (vlax-invoke-method obj 'BrowseForFolder 0 msg 49))
    
13.   (if folders
    
14.     (progn
    
15.        (setq path1 (vlax-get-property folders 'Title))
    
16.        (cond ((eq "桌面" path1)
    
17.               (setq path "C:\\WINDOWS\\Desktop\")
    
18.              )
    
19.              ((eq "我的文档" path1)
    
20.               (setq path "C:\\My Documents\")
    
21.              )  
    
22.              (T         
    
23.               (while index
    
24.                  (setq path1 (vlax-get-property folders 'Title))
    
25.                  (if (or (eq "我的电脑" path1) (eq "我的文档" path1))
    
26.                      (setq index nil)
    
27.                      (progn
    
28.                          (setq dirlist (append dirlist (list path1)))
    
29.                          (setq folders (vlax-get-property folders 'ParentFolder))
    
30.                      )
    
31.                  )                           
    
32.               )
    
33.               (cond ((eq "我的电脑" path1)
    
34.                      (setq dirlist (reverse dirlist))
    
35.                      (setq path2 (car dirlist))
    
36.                      (setq dirlist0 (cdr dirlist))
    
37.                      (if dirlist0
    
38.                         (progn
    
39.                            (setq path (substr path2 (- (strlen path2) 2) 2))        
    
40.                            (princ "\n")
    
41.                            (foreach n  dirlist0
    
42.                                (setq path (strcat path "\" n))
    
43.                            )
    
44.                            (setq path (strcat path "\"))
    
45.                         )  
    
46.                         (progn
    
47.                            (princ "\n")
    
48.                            (setq path (strcat (substr path2 (- (strlen path2) 2) 2) "\"))
    
49.                         )
    
50.                      )
    
51.                    )
    
52.                    ((eq "我的文档" path1)
    
53.                      (setq dirlist (reverse dirlist))
    
54.                      (setq path "C:\\My Documents")
    
55.                      (foreach n dirlist
    
56.                           (setq path (strcat path "\" n))
    
57.                      )
    
58.                      (setq path (strcat path "\"))
    
59.                   )
    
60.                   (T nil)                  
    
61.               );cond
    
62.             )
    
63.         );cond
    
64.     );PROGN
    
65.     nil
    
66.   )     
    
67. )
    
68.   [/FONT]
    

<br />   [FONT=courier new]<br /> (defun HBrowseFolder (msg / index dirlist obj folders path1 dirlist0 path)<br />   (if (null msg)<br />     (setq msg "Select folder")<br />   )<br />   (setq index T)<br />   (setq dirlist '() path nil)<br />   (vl-load-com)<br />   (setq obj (vlax-create-object "Shell.Application"))<br />   (setq folders (vlax-invoke-method obj 'BrowseForFolder 0 msg 49))<br />   (if folders<br />     (progn<br />        (setq path1 (vlax-get-property folders 'Title))<br />        (cond ((eq "桌面" path1)<br />               (setq path "C:\\WINDOWS\\Desktop\")<br />              )<br />              ((eq "我的文档" path1)<br />               (setq path "C:\\My Documents\")<br />              )  <br />              (T          <br />               (while index<br />                  (setq path1 (vlax-get-property folders 'Title))<br />                  (if (or (eq "我的电脑" path1) (eq "我的文档" path1))<br />                      (setq index nil) <br />                      (progn<br />                          (setq dirlist (append dirlist (list path1)))<br />                          (setq folders (vlax-get-property folders 'ParentFolder))<br />                      ) <br />                  )                            <br />               )<br />               (cond ((eq "我的电脑" path1)<br />                      (setq dirlist (reverse dirlist))<br />                      (setq path2 (car dirlist))<br />                      (setq dirlist0 (cdr dirlist))<br />                      (if dirlist0<br />                         (progn<br />                            (setq path (substr path2 (- (strlen path2) 2) 2))        <br />                            (princ "\n")<br />                            (foreach n  dirlist0 <br />                                (setq path (strcat path "\" n))<br />                            ) <br />                            (setq path (strcat path "\")) <br />                         )  <br />                         (progn<br />                            (princ "\n")<br />                            (setq path (strcat (substr path2 (- (strlen path2) 2) 2) "\"))<br />                         )<br />                      )<br />                    )<br />                    ((eq "我的文档" path1)<br />                      (setq dirlist (reverse dirlist))<br />                      (setq path "C:\\My Documents")<br />                      (foreach n dirlist<br />                           (setq path (strcat path "\" n))<br />                      ) <br />                      (setq path (strcat path "\")) <br />                   ) <br />                   (T nil)                  <br />               );cond <br />             )<br />         );cond<br />     );PROGN<br />     nil<br />   )     <br /> )<br />   [/FONT]<br />