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
Const BIF_RETURNONLYFSDIRS = &H1
Dim pidl As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (Byval pidl As Long, Byval pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetSourceFolder As String
On Error Goto errorline 
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer
'句柄
bi.hOwner = hWnd 
'展開根目錄
bi.pidlRoot = 0& 
'列表框標(biāo)題
bi.lpszTitle = "請選擇文件的路徑："
'規(guī)定只能選擇文件夾，其他無效
bi.ulFlags = BIF_RETURNONLYFSDIRS
'調(diào)用API函數(shù)顯示列表框
pidl = SHBrowseForFolder(bi)
'利用API函數(shù)獲取返回的路徑
path = Space$(512)
r = SHGetPathFromIDList(Byval pidl&, Byval path)
If r Then
  pos = Instr(path, Chr$(0)) 
  GetSourceFolder = Left(path, pos - 1)
Else
  GetSourceFolder = "" 
End If
Exit Function
errorline:
GetSourceFolder = ""
continue = False
Exit Function
End Function