vb中 打开文件夹浏览框的方法总结

       众所周知，在vb中如果是打开某一个文件的话，非常简单，使用CommonDialog组件即可轻松完成，但是他只能选择文件，之后或许选取的文件路径，而如果想要浏览文件夹，就没这么方便了。

这里介绍3个办法来实现文件夹浏览。

第一个非常简单，利用Shell对象
 程序代码
'引用Microsoft Shell Controls And Automation
Dim ShellA As New Shell
Private Sub Command1_Click()    '建立一个按钮对象                                                    
Dim Shellb As Shell32.Folder
Set Shellb = ShellA.BrowseForFolder(0, "选择文件夹", 0)
ShellA.Open b
End Sub

记得一定要引用Microsoft Shell Controls And Automation

第二种方法，我们同样利用shell对象，但是加几个函数

程序代码

'引用Microsoft Shell Controls And Automation
Private shlShell As Shell32.Shell
Private shlFolder As Shell32.Folder
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Sub Command1_Click() '
    If shlShell Is Nothing Then
       Set shlShell = New Shell32.Shell
    End If
    Set shlFolder = shlShell.BrowseForFolder(Me.hWnd, "请选择文件夹", BIF_RETURNONLYFSDIRS)
    If Not shlFolder Is Nothing Then
       MsgBox shlFolder.Items.Item.Path  '测试
    End If
End Sub

上面2个方法的结果如图：


第三个方法，是利用API来操作。

 程序代码

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
     hWndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags    As Long
     lpfnCallback     As Long
     lParam     As Long
     iImage     As Long
End Type
Private Sub Command1_Click()
     Dim lpIDList As Long
     Dim sBuffer As String
     Dim szTitle As String
     Dim tBrowseInfo As BrowseInfo
     szTitle = App.Path
     With tBrowseInfo
          .hWndOwner = Me.hWnd
          .lpszTitle = lstrcat(szTitle, "")
          .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
     End With

     lpIDList = SHBrowseForFolder(tBrowseInfo)
     If (lpIDList) Then
          sBuffer = Space(MAX_PATH)
          SHGetPathFromIDList lpIDList, sBuffer
          sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
          MsgBox sBuffer
     End If
End Sub

如果希望对话框中有“新建文件夹”，那么就给.ulFlags 加上BIF_USENEWUI属性，BIF_RETURNONLYFSDIRS 的意思是仅仅返回文件夹。
效果如图：


同时我也打包2个完整的利用此API的代码，有意者请自己学习了。


第4个方法。
其实是第三个方法的改进，就是打开对话框后，自动定位到当前文件夹位置 。

程序代码

'Objects:   Form1、Command1、Module1  
  'Form1:  
  Option   Explicit  
  Private   Const   BIF_RETURNONLYFSDIRS   =   1  
  Private   Const   BIF_DONTGOBELOWDOMAIN   =   2  
  Private   Const   MAX_PATH   =   260  
  Private   Declare   Function   SHBrowseForFolder   Lib   "shell32"   (lpbi   As   BrowseInfo)   As   Long  
  Private   Declare   Function   SHGetPathFromIDList   Lib   "shell32"   (ByVal   pidList   As   Long,   ByVal   lpBuffer   As   String)   As   Long  
  Private   Declare   Function   lstrcat   Lib   "kernel32"   Alias   "lstrcatA"   (ByVal   lpString1   As   String,   ByVal   lpString2   As   String)   As   Long  
  Private   Declare   Function   LocalAlloc   Lib   "kernel32"   (ByVal   uFlags   As   Long,   ByVal   uBytes   As   Long)   As   Long  
  Private   Declare   Sub   CopyMemory   Lib   "kernel32"   Alias   "RtlMoveMemory"   (pDest   As   Any,   pSource   As   Any,   ByVal   dwLength   As   Long)  
  Private   Const   LPTR   =   (&H0   or   &H40)  
  Private   Type   BrowseInfo  
                  hWndOwner             As   Long  
                  pIDLRoot             As   Long  
                  pszDisplayName   As   Long  
                  lpszTitle             As   Long  
                  ulFlags                 As   Long  
                  lpfnCallback     As   Long  
                  lParam                 As   Long  
                  iImage                 As   Long  
  End   Type  
  Private   Function   MyAddressOf(AddressOfX   As   Long)   As   Long  
  MyAddressOf   =   AddressOfX  
  End   Function  
    
  Private   Sub   Command1_Click()  
  Dim   lpIDList   As   Long  
  Dim   sBuffer   As   String  
  Dim   szTitle   As   String  
  Dim   tBrowseInfo   As   BrowseInfo  
  Dim   Ret   As   Long  
  szTitle   =   "This   is   the   title"  
  Dim   sPath   As   String  
  sPath   =   VBA.InputBox("初始路径:",   ,   "C:\program   files")  
  With   tBrowseInfo  
          .hWndOwner   =   Me.hWnd  
          .lpszTitle   =   lstrcat(szTitle,   "")  
          .ulFlags   =   BIF_RETURNONLYFSDIRS   +   BIF_DONTGOBELOWDOMAIN  
          .lpfnCallback   =   MyAddressOf(AddressOf   BrowseForFolders_CallbackProc)  
          Ret   =   LocalAlloc(LPTR,   VBA.Len(sPath)   +   1)  
          CopyMemory   ByVal   Ret,   ByVal   sPath,   VBA.Len(sPath)   +   1  
          .lParam   =   Ret  
  End   With  
  lpIDList   =   SHBrowseForFolder(tBrowseInfo)  
  If   (lpIDList)   Then  
      sBuffer   =   VBA.Space(MAX_PATH)  
      SHGetPathFromIDList   lpIDList,   sBuffer  
      sBuffer   =   VBA.Left(sBuffer,   VBA.InStr(sBuffer,   vbNullChar)   -   1)  
      MsgBox   sBuffer  
      End   If  
  End   Sub  
    
  'Module1:  
  Option   Explicit  
  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  
  Private   Const   WM_USER   =   &H400  
  Private   Const   BFFM_SETSelectIONA   As   Long   =   (WM_USER   +   102)  
  Private   Const   BFFM_SETSelectIONW   As   Long   =   (WM_USER   +   103)  
  Private   Const   BFFM_INITIALIZED   As   Long   =   1  
  Public   Function   BrowseForFolders_CallbackProc(ByVal   hWnd   As   Long,   ByVal   uMsg   As   Long,   ByVal   lParam   As   Long,   ByVal   lpData   As   Long)   As   Long  
  If   uMsg   =   BFFM_INITIALIZED   Then  
      SendMessage   hWnd,   BFFM_SETSelectIONA,   True,   ByVal   lpData  
  End   If  
  End   Function

效果如图：



看了这个代码后，你会发现它确实定位到了当前文件夹，但是他有一个问题就是，没有选定当前文件夹。咱们继续看方法5.

第5个方法。
他同样是第3个方法的加强版，不过这个方法应当是最为完美的方法，不仅定位到当前文件夹，而且选定它。
建立一个模块文件

程序代码

'form1
''Module1:  
Option Explicit
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSelectION = (WM_USER + 102)

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
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Private Type BrowseInfo
  hWndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End Type

Private m_CurrentDirectory As String   'The current directory
Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  m_CurrentDirectory = StartDir & vbNullChar

  szTitle = Title
  With tBrowseInfo
    .hWndOwner = owner.hWnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With

  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  
End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
    Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String  
  On Error Resume Next      
  Select Case uMsg  
    Case BFFM_INITIALIZED
      Call SendMessage(hWnd, BFFM_SETSelectION, 1, m_CurrentDirectory)      
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
      
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If      
  End Select  
  BrowseCallbackProc = 0  
End Function
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function

建立一个窗口和一个按钮

 程序代码

Option Explicit
Private getdir As String
Private Sub Command1_Click()    
    getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)
    If Len(getdir) = 0 Then Exit Sub     Text1.Text = getdir    
End Sub
Private Sub Form_Load()
  Text1.Text = CurDir
End Sub

最终结果如图：


上面是对vb中调用文件夹对话框的一个总结，个人认为第5个方法是最为完美的，这也是从国外坛子淘到的

不得不说，国外对源码共享还是走在我们前面的。

====================

VB选择文件夹(比较顺眼的)

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Type SHITEMID
cb As Long
abID As Byte
End Type
Public Type ITEMIDLIST
mkid As SHITEMID
End Type

Function getFolder(frm As Form, Optional Flags As Long = 1) As String
On Error Resume Next
Dim BI As BROWSEINFO
Dim IDL As ITEMIDLIST
Dim r As Long
Dim pidl As Long
Dim tmpPath As String
Dim pos As Integer

BI.hOwner = frm.hwnd
BI.pidlRoot = 0&
BI.lpszTitle = "请选择路径："
'bi.ulFlags = BIF_RETURNONLYFSDIRS
'BIF_DEFAULT = 0x0000,
'BIF_BROWSEFORCOMPUTER = 0x1000,效果不明
'BIF_BROWSEFORPRINTER = 0x2000,效果不明
'BIF_BROWSEINCLUDEFILES = 0x4000,效果不明
'BIF_BROWSEINCLUDEURLS = 0x0080,效果不明
'BIF_DONTGOBELOWDOMAIN = 0x0002,;效果不明
'BIF_EDITBOX = 0x0010,带文件夹名称编辑框
'BIF_NEWDIALOGstyle = 0x0040,带新建文件夹
'BIF_NONEWFOLDERBUTTON = 0x0200,没有菜单
'BIF_RETURNFSANCESTORS = 0x0008,效果不明
'BIF_RETURNONLYFSDIRS = 0x0001,;默认
'BIF_SHAREABLE = 0x8000,效果不明
'BIF_STATUSTEXT = 0x0004,;效果不明
'BIF_UAHINT = 0x0100,效果不明
'BIF_VALIDATE = 0x0020,效果不明
'BIF_NOTRANSLATETARGETS = 0x0400,效果不明

BI.ulFlags = Flags
'get the folder
pidl = SHBrowseForFolder(BI)

tmpPath = Space$(512)
r = SHGetPathFromIDList(ByVal pidl, ByVal tmpPath)
getFolder = ""

If r Then
pos = InStr(tmpPath, Chr$(0))
tmpPath = Trim(Left(tmpPath, pos - 1))
If Right(tmpPath, 1) <> "\" Then tmpPath = tmpPath & "\"
getFolder = Trim(tmpPath)
End If
End Function

=======================

[VB]用API打开浏览文件夹对话框，选择文件夹

Option Explicit

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = &H1 '浏览文件夹
Private Const BIF_NEWDIALOGSTYLE = &H40 '新样式（有新建文件夹按钮，可调整对话框大小）
Private Const BIF_NONEWFOLDERBUTTON = &H200 '新样式中，没有新建按钮（只调大小）

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, _
  ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
  (lpBrowseInfo As BROWSEINFO) As Long

Public Function GetFolderName(hWnd As Long, Text As String) As String
  Dim bi As BROWSEINFO
  Dim pidl As Long
  Dim path As String
  With bi
    .hOwner = hWnd
    .pidlRoot = 0&  '根目录，一般不需要改
    .lpszTitle = Text
    .ulFlags = BIF_RETURNONLYFSDIRS '根据需要调整
  End With
  pidl = SHBrowseForFolder(bi)
  path = Space$(512)
  If SHGetPathFromIDList(ByVal pidl, ByVal path) Then
    GetFolderName = Left(path, InStr(path, Chr(0)) - 1)
  End If
End Function