【转】API调用打开文件夹对话框

'在窗体中加一个按钮,把下列代码加入窗体中,运行即可
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As _ 
 BROWSEINFO) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, _ 
 ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long
Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal _ 
dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal _ 
szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ 
(ByVal pIdl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Const SHGFI_PIDL = &H8                           '  pszPath is a pidl
Private Const NOERROR = 0
Private Const SHGFI_ICON = &H100
Private Const SHGFI_SMALLICON = &H1

' **********************************************************************
'  描  述：API调用打开文件夹对话框
'  Play78.com : 网站导航,源码之家,绝对开源
'  海阔天空收集整理
'  主站地址：http://www.play78.com/
'  源码下载地址：http://www.play78.com/blog
'  图片下在地址：http://www.play78.com/pic
'  QQ：13355575
'  e-mail:hglai@eyou.com
'  编写日期：2005年08月26日
' **********************************************************************

Const MAX_PATH = 260

Private Type SHITEMID
    cb As Long
    abID() As Byte
End Type

Private Type ITEMIDLIST
    mkid As SHITEMID
End Type

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 Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
Private Function GetFolderValue(wIdx As Integer) As Long
    If wIdx < 2 Then
        GetFolderValue = 0
    ElseIf wIdx < 12 Then
        GetFolderValue = wIdx
    Else
        GetFolderValue = wIdx + 4
    End If
End Function

Private Sub Command1_Click()
  Dim BI As BROWSEINFO
  Dim nFolder As Long
  Dim IDL As ITEMIDLIST
  Dim pIdl As Long
  Dim sPath As String
  Dim SHFI As SHFILEINFO
  Dim m_wCurOptIdx As Integer
  Dim txtPath As String
  Dim txtDisplayName As String
  
  With BI
    .hOwner = Me.hwnd
    nFolder = GetFolderValue(m_wCurOptIdx)
    If SHGetSpecialFolderLocation(ByVal Me.hwnd, ByVal nFolder, IDL) = NOERROR Then
      .pidlRoot = IDL.mkid.cb
    End If
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = "www.Play78.com api调用打开文件夹对话框事例 "
    .ulFlags = 0
  End With
  
  txtPath = ""
  txtDisplayName = ""
  pIdl = SHBrowseForFolder(BI)
  If pIdl = 0 Then Exit Sub
  sPath = String$(MAX_PATH, 0)
  SHGetPathFromIDList ByVal pIdl, ByVal sPath

  txtPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
  txtDisplayName = Left$(BI.pszDisplayName, InStr(BI.pszDisplayName, vbNullChar) - 1)
  
  SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), SHGFI_PIDL Or SHGFI_ICON Or SHGFI_SMALLICON
  
  SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), SHGFI_PIDL Or SHGFI_ICON
  CoTaskMemFree pIdl
  MsgBox "你选择的文件夹是" + Chr(13) + Chr(10) + txtPath
End Sub