【K:BrowPath】选择或浏览文件夹

kucha007

选择或浏览文件夹，原帖在选择盘符时会带反斜杆，而选择文件夹则不会。
在原帖的基础上做了一点改动，统一先修剪掉斜杆再添加，不选文件夹时返回当前文件的路径
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=6239&highlight=%D1%A1%D4%F1%2B%CE%C4%BC%FE%BC%D0

1. (defun K:BrowPath (/ msg WinShell shFolder err path)
   
2.   (vl-load-com)
   
3.   (setq msg "请选择文件夹路径(默认为当前文件路径)：")
   
4.   (setq winshell (vlax-create-object "Shell.Application"))
   
5.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
   
6.   (setq err (vl-catch-all-apply
   
7.                   '(lambda ()
   
8.                     (setq shFolder (vlax-get-property shFolder 'self))
   
9.                     (setq path (vl-string-right-trim "\\"
   
10.                                   (vl-string-translate "/" "\\"
    
11.                                     (vlax-get-property shFolder 'path)
    
12.                                   )
    
13.                                 )
    
14.                     )
    
15.                   )
    
16.                 )
    
17.   )
    
18.   (if (vl-catch-all-error-p err)
    
19.     (getvar "dwgprefix");选择取消时,返回当前文件路径
    
20.     (strcat path "\\");选择确定时,返回所选文件夹路径
    
21.   )
    
22. )
    

(defun K:BrowPath (/ msg WinShell shFolder err path) <br />   (vl-load-com)<br />   (setq msg "请选择文件夹路径(默认为当前文件路径)：")<br />   (setq winshell (vlax-create-object "Shell.Application"))<br />   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))<br />   (setq err (vl-catch-all-apply <br />                   '(lambda () <br />                     (setq shFolder (vlax-get-property shFolder 'self))<br />                     (setq path (vl-string-right-trim "\\" <br />                                   (vl-string-translate "/" "\\" <br />                                     (vlax-get-property shFolder 'path)<br />                                   )<br />                                 )<br />                     )<br />                   )<br />                 )<br />   )<br />   (if (vl-catch-all-error-p err) <br />     (getvar "dwgprefix");选择取消时,返回当前文件路径<br />     (strcat path "\\");选择确定时,返回所选文件夹路径<br />   )<br /> )<br />

lxl217114

很高产，很赞很给力

HAZEL

搜了半天终于找到我需要的程序，感谢楼主。

yefei812678

很高产，很赞很给力