VB 调用系统API 选择文件夹 代码

Option   Explicit

'Powered by barenx
Private   Declare   Function SHBrowseForFolder() Function SHBrowseForFolder Lib "shell32.dll" Alias _
        "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetSpecialFolderLocation()Function SHGetSpecialFolderLocation Lib _
        "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _
        As Long, pIdl As ITEMIDLIST) As Long

Private Declare Function SHGetFileInfo()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()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()Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal _
        pszPath As String) As Long
Private Declare Sub CoTaskMemFree()Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)


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 Const MAX_PATH = 260

Private Type SHFILEINFO
    HIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
Private Const ERROR_SUCCESS = 0&
'Private Const SHGNLI_PIDL = &H1
'Private Const SHGFI_ICON = &H100
'Private Const SHGFI_SMALLICON = &H1


Private Function GetFolderValue()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 Label3_Click()Sub Label3_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) = ERROR_SUCCESS Then
      .pidlRoot = IDL.mkid.cb
    End If
    
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = "Browsing is limited to: "
    .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
  TxtSet(0).Text = txtPath
End Sub