使用API方法调用浏览文件夹对话框

时　间:2019-06-28 22:18:25
作　者:杨雪   ID：42182  城市：南京
摘　要:VBA 使用API方法调用浏览文件夹对话框。
正　文:

源码：

	'【类型声明】
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



	'【API声明】
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
Private Declare Function lstrcat Lib "kernel32" _
                                 Alias "lstrcatA" (ByVal lpString1 As String, _
                                                   ByVal lpString2 As String) As Long
Private Declare Function OleInitialize Lib "ole32.dll" _
                                       (lp As Any) As Long
Private Declare Sub OleUninitialize Lib "ole32" ()
Private Const BIF_USENEWUI = &H40
Private Const MAX_PATH = 260



	'【自定义函数】
Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As String
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim BInfo As BROWSEINFO
    If IsMissing(vFlags) Then vFlags = BIF_USENEWUI
    Call OleInitialize(ByVal 0&)
    With BInfo
        .lpszTitle = lstrcat(sTitle, "")
        .ulFlags = vFlags
    End With
    lpIDList = SHBrowseForFolder(BInfo)
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        If sBuffer <> "" Then GetFolder_API = sBuffer
    End If
    Call OleUninitialize
End Function



	'【使用方法】
Sub Test()
    MsgBox GetFolder_API("选择文件夹")
End Sub