VBA 浏览文件夹对话框调用的几种方法

    1、使用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


    2、使用Shell.Application方法

    复制代码 代码如下:

    Sub GetFloder_Shell()
    Set objShell = CreateObject(“Shell.Application”)
    Set objFolder = objShell.BrowseForFolder(0, “选择文件夹”, 0, 0)
    If Not objFolder Is Nothing Then
    MsgBox objFolder.self.path
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    End Sub


    3、使用FileDialog方法

    复制代码 代码如下:

    Sub GetFloder_FileDialog()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then MsgBox fd.SelectedItems(1)
    Set fd = Nothing
    End Sub


    以上方法在WINXP+OFFICE2003中测试通过

Leave a Reply

Leave a Reply