提醒 银行 社区应用 最新帖子 精华区 社区服务 会员列表 统计排行 搜索 帮助
主题 : 【原创】vb中5种打开文件夹浏览框的方法总结
daokers 离线
知名网络安全老顽童
级别: 管理员

UID: 4
精华: 65
发帖: 2288
刀币: 139 个
威望: 64 点
贡献值: 10 点
银元: 0 个
好评度: 0 点
在线时间: 1348(时)
注册时间: 2010-01-10
最后登录: 2018-12-29
楼主  发表于: 2010-03-12   
┊一键分享: 腾讯微博 新浪微博新浪微博
0
来源于 原创 分类

【原创】vb中5种打开文件夹浏览框的方法总结

管理提醒: 本帖被 daokers 从 编程技术{About Program} 移动到本区(2010-04-03)
` wj'  
众所周知,在vb中如果是打开某一个文件的话,非常简单,使用CommonDialog组件即可轻松完成,但是他只能选择文件,之后或许选取的文件路径,而如果想要浏览文件夹,就没这么方便了。 pQ^V<6z}  
AG%[?1IXW  
这里介绍3个办法来实现文件夹浏览。 tD#)  
DS @Yto  
第一个非常简单,利用Shell对象 "|&3z/AUh  
复制代码
  1. '引用Microsoft Shell Controls And Automation
  2. Dim ShellA As New Shell
  3. Private Sub Command1_Click()      '建立一个按钮对象                                                    
  4. Dim Shellb As Folder
  5. Set Shellb = ShellA.BrowseForFolder(0, "选择文件夹", 0)
  6. ShellA.Open b
  7. End Sub
4=y&}3om(0  
_~umE/tz  
记得一定要引用Microsoft Shell Controls And Automation S"^'ksL\  
}#&[[}@th  
第二种方法,我们同样利用shell对象,但是加几个函数 Ax=)J{4v  
复制代码
  1. '引用Microsoft Shell Controls And Automation
  2. Private shlShell As Shell32.Shell
  3. Private shlFolder As Shell32.Folder
  4. Private Const BIF_RETURNONLYFSDIRS = &H1
  5. Private Sub Command1_Click() '
  6.     If shlShell Is Nothing Then
  7.        Set shlShell = New Shell32.Shell
  8.     End If
  9.     Set shlFolder = shlShell.BrowseForFolder(Me.hWnd, "请选择文件夹", BIF_RETURNONLYFSDIRS)
  10.     If Not shlFolder Is Nothing Then
  11.        MsgBox shlFolder.Items.Item.Path  '测试
  12.     End If
  13. End Sub
*+6iXMwe  
Vz-q7*o $S  
上面2个方法的结果如图: PC255  

s7:_!Nd@8  
"u$XEA  
第三个方法,是利用API来操作。 }{,Wha5\n  
复制代码
  1. Private Const BIF_RETURNONLYFSDIRS = 1
  2. Private Const BIF_DONTGOBELOWDOMAIN = 2
  3. Private Const MAX_PATH = 260
  4. Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
  5. Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  6. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  7. Private Type BrowseInfo
  8.      hWndOwner As Long
  9.      pIDLRoot As Long
  10.      pszDisplayName As Long
  11.      lpszTitle As Long
  12.      ulFlags    As Long
  13.      lpfnCallback     As Long
  14.      lParam     As Long
  15.      iImage     As Long
  16. End Type
  17. Private Sub Command1_Click()
  18.      Dim lpIDList As Long
  19.      Dim sBuffer As String
  20.      Dim szTitle As String
  21.      Dim tBrowseInfo As BrowseInfo
  22.      szTitle = App.Path
  23.      With tBrowseInfo
  24.           .hWndOwner = Me.hWnd
  25.           .lpszTitle = lstrcat(szTitle, "")
  26.           .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
  27.      End With
  28.      lpIDList = SHBrowseForFolder(tBrowseInfo)
  29.      If (lpIDList) Then
  30.           sBuffer = Space(MAX_PATH)
  31.           SHGetPathFromIDList lpIDList, sBuffer
  32.           sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  33.           MsgBox sBuffer
  34.      End If
  35. End Sub
xf7YIhL^*  
如果希望对话框中有“新建文件夹”,那么就给.ulFlags 加上BIF_USENEWUI属性,BIF_RETURNONLYFSDIRS 的意思是仅仅返回文件夹。 X+u1p?  
效果如图: vQ2{ +5!|  

/d"@$+  
V)5,E>;EN  
同时我也打包2个完整的利用此API的代码,有意者请自己学习了。 Q*'OY~  
km^ZF<.@  
@6R6.i5d  
第4个方法。 1#AxFdm1  
其实是第三个方法的改进,就是打开对话框后,自动定位到当前文件夹位置 。 .qYQ 3G'V  
复制代码
  1. 'Objects:   Form1、Command1、Module1  
  2.   'Form1:  
  3.   Option   Explicit  
  4.   Private   Const   BIF_RETURNONLYFSDIRS   =   1  
  5.   Private   Const   BIF_DONTGOBELOWDOMAIN   =   2  
  6.   Private   Const   MAX_PATH   =   260  
  7.   Private   Declare   Function   SHBrowseForFolder   Lib   "shell32"   (lpbi   As   BrowseInfo)   As   Long  
  8.   Private   Declare   Function   SHGetPathFromIDList   Lib   "shell32"   (ByVal   pidList   As   Long,   ByVal   lpBuffer   As   String)   As   Long  
  9.   Private   Declare   Function   lstrcat   Lib   "kernel32"   Alias   "lstrcatA"   (ByVal   lpString1   As   String,   ByVal   lpString2   As   String)   As   Long  
  10.   Private   Declare   Function   LocalAlloc   Lib   "kernel32"   (ByVal   uFlags   As   Long,   ByVal   uBytes   As   Long)   As   Long  
  11.   Private   Declare   Sub   CopyMemory   Lib   "kernel32"   Alias   "RtlMoveMemory"   (pDest   As   Any,   pSource   As   Any,   ByVal   dwLength   As   Long)  
  12.   Private   Const   LPTR   =   (&H0   Or   &H40)  
  13.   Private   Type   BrowseInfo  
  14.                   hWndOwner             As   Long  
  15.                   pIDLRoot             As   Long  
  16.                   pszDisplayName   As   Long  
  17.                   lpszTitle             As   Long  
  18.                   ulFlags                 As   Long  
  19.                   lpfnCallback     As   Long  
  20.                   lParam                 As   Long  
  21.                   iImage                 As   Long  
  22.   End   Type  
  23.   Private   Function   MyAddressOf(AddressOfX   As   Long)   As   Long  
  24.   MyAddressOf   =   AddressOfX  
  25.   End   Function  
  26.     
  27.   Private   Sub   Command1_Click()  
  28.   Dim   lpIDList   As   Long  
  29.   Dim   sBuffer   As   String  
  30.   Dim   szTitle   As   String  
  31.   Dim   tBrowseInfo   As   BrowseInfo  
  32.   Dim   Ret   As   Long  
  33.   szTitle   =   "This   is   the   title"  
  34.   Dim   sPath   As   String  
  35.   sPath   =   VBA.InputBox("初始路径:",   ,   "C:\program   files")  
  36.   With   tBrowseInfo  
  37.           .hWndOwner   =   Me.hWnd  
  38.           .lpszTitle   =   lstrcat(szTitle,   "")  
  39.           .ulFlags   =   BIF_RETURNONLYFSDIRS   +   BIF_DONTGOBELOWDOMAIN  
  40.           .lpfnCallback   =   MyAddressOf(AddressOf   BrowseForFolders_CallbackProc)  
  41.           Ret   =   LocalAlloc(LPTR,   VBA.Len(sPath)   +   1)  
  42.           CopyMemory   ByVal   Ret,   ByVal   sPath,   VBA.Len(sPath)   +   1  
  43.           .lParam   =   Ret  
  44.   End   With  
  45.   lpIDList   =   SHBrowseForFolder(tBrowseInfo)  
  46.   If   (lpIDList)   Then  
  47.       sBuffer   =   VBA.Space(MAX_PATH)  
  48.       SHGetPathFromIDList   lpIDList,   sBuffer  
  49.       sBuffer   =   VBA.Left(sBuffer,   VBA.InStr(sBuffer,   vbNullChar)   -   1)  
  50.       MsgBox   sBuffer  
  51.       End   If  
  52.   End   Sub  
  53.     
  54.   'Module1:  
  55.   Option   Explicit  
  56.   Private   Declare   Function   SendMessage   Lib   "user32"   Alias   "SendMessageA"   (ByVal   hWnd   As   Long,   ByVal   wMsg   As   Long,   ByVal   wParam   As   Long,   lParam   As   Any)   As   Long  
  57.   Private   Const   WM_USER   =   &H400  
  58.   Private   Const   BFFM_SETSELECTIONA   As   Long   =   (WM_USER   +   102)  
  59.   Private   Const   BFFM_SETSELECTIONW   As   Long   =   (WM_USER   +   103)  
  60.   Private   Const   BFFM_INITIALIZED   As   Long   =   1  
  61.   Public   Function   BrowseForFolders_CallbackProc(ByVal   hWnd   As   Long,   ByVal   uMsg   As   Long,   ByVal   lParam   As   Long,   ByVal   lpData   As   Long)   As   Long  
  62.   If   uMsg   =   BFFM_INITIALIZED   Then  
  63.       SendMessage   hWnd,   BFFM_SETSELECTIONA,   True,   ByVal   lpData  
  64.   End   If  
  65.   End   Function
GA[bo)"  
QKVOc,Fp7i  
效果如图: Z1$U[Tsd  

/yx)_x{  
ywyg(8>zE  
看了这个代码后,你会发现它确实定位到了当前文件夹,但是他有一个问题就是,没有选定当前文件夹。咱们继续看方法5. # SJJ@SM  
cCx{ ")  
第5个方法。  nsV =  
他同样是第3个方法的加强版,不过这个方法应当是最为完美的方法,不仅定位到当前文件夹,而且选定它。 :.a184ax  
建立一个模块文件 ;GOu'34j  
复制代码
  1. 'form1
  2. ''Module1:  
  3. Option Explicit
  4. Private Const BIF_STATUSTEXT = &H4&
  5. Private Const BIF_RETURNONLYFSDIRS = 1
  6. Private Const BIF_DONTGOBELOWDOMAIN = 2
  7. Private Const MAX_PATH = 260
  8. Private Const WM_USER = &H400
  9. Private Const BFFM_INITIALIZED = 1
  10. Private Const BFFM_SELCHANGED = 2
  11. Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
  12. Private Const BFFM_SETSELECTION = (WM_USER + 102)
  13. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  14. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  15. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  16. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  17. Private Type BrowseInfo
  18.   hWndOwner      As Long
  19.   pIDLRoot       As Long
  20.   pszDisplayName As Long
  21.   lpszTitle      As Long
  22.   ulFlags        As Long
  23.   lpfnCallback   As Long
  24.   lParam         As Long
  25.   iImage         As Long
  26. End Type
  27. Private m_CurrentDirectory As String   'The current directory
  28. Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
  29.   Dim lpIDList As Long
  30.   Dim szTitle As String
  31.   Dim sBuffer As String
  32.   Dim tBrowseInfo As BrowseInfo
  33.   m_CurrentDirectory = StartDir & vbNullChar
  34.   szTitle = Title
  35.   With tBrowseInfo
  36.     .hWndOwner = owner.hWnd
  37.     .lpszTitle = lstrcat(szTitle, "")
  38.     .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
  39.     .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  40.   End With
  41.   lpIDList = SHBrowseForFolder(tBrowseInfo)
  42.   If (lpIDList) Then
  43.     sBuffer = Space(MAX_PATH)
  44.     SHGetPathFromIDList lpIDList, sBuffer
  45.     sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  46.     BrowseForFolder = sBuffer
  47.   Else
  48.     BrowseForFolder = ""
  49.   End If
  50.   
  51. End Function
  52. Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  53.     Dim lpIDList As Long
  54.   Dim ret As Long
  55.   Dim sBuffer As String  
  56.   On Error Resume Next      
  57.   Select Case uMsg  
  58.     Case BFFM_INITIALIZED
  59.       Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)      
  60.     Case BFFM_SELCHANGED
  61.       sBuffer = Space(MAX_PATH)
  62.       
  63.       ret = SHGetPathFromIDList(lp, sBuffer)
  64.       If ret = 1 Then
  65.         Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
  66.       End If      
  67.   End Select  
  68.   BrowseCallbackProc = 0  
  69. End Function
  70. Private Function GetAddressofFunction(add As Long) As Long
  71.   GetAddressofFunction = add
  72. End Function
i<tJG{A=  
建立一个窗口和一个按钮 '<ZHzDW@  
复制代码
  1. Option Explicit
  2. Private getdir As String
  3. Private Sub Command1_Click()    
  4.     getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)
  5.     If Len(getdir) = 0 Then Exit Sub     Text1.Text = getdir    
  6. End Sub
  7. Private Sub Form_Load()
  8.   Text1.Text = CurDir
  9. End Sub
B#5[PX  
&?xmu204  
最终结果如图: ){eQ.yW  

x`IWo:j  
9OY ao  
上面是对vb中调用文件夹对话框的一个总结,个人认为第5个方法是最为完美的,这也是从国外坛子淘到的 61gyx6v  
,j w`9a  
不得不说,国外对源码共享还是走在我们前面的。 Zvfy%k   
)4:]gx#cr  
全文完 Ix@B*Xz:`  
1_c%p#?K  
by  daokers gnxD'1_  
2010.3.12  于广州 %Kp^wf#o9  
B J  I N  
2:nI4S  
cg9}T[A  
}?+tX<j  
虽出生在浊世,但追求的是纯洁。
plstols 离线
www.hack-man.cn
级别: 刀城贵人
UID: 18
精华: 4
发帖: 74
刀币: 18 个
威望: 4 点
贡献值: 0 点
银元: 0 个
好评度: 0 点
在线时间: 54(时)
注册时间: 2010-01-10
最后登录: 2010-08-08
沙发  发表于: 2010-03-31   
刀哥发的东西不得不顶。。给我能加几个刀币就好了
www.hack-man.cn
描述
快速回复

如果您在写长篇帖子又不马上发表,建议存为草稿
验证问题:
刀客城域名是多少?(www.daokers.net) 正确答案:www.daokers.net
按"Ctrl+Enter"直接提交
上一个 下一个