Excel中调用VBA选择目标文件夹

进行文件操作时，经常要用 VBA 选择目标文件夹，现提供实现代码：

   1.FileDialog 属性

Sub Sample1()
     With Application.FileDialog(msoFileDialogFolderPicker)
         If .Show = True Then
             MsgBox .SelectedItems(1)
         End If
     End With
End Sub

   2.shell 方法

Sub Sample2()
     Dim Shell, myPath
     Set Shell = CreateObject("Shell.Application")
     Set myPath = Shell.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, "G:\")
     If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
     Set Shell = Nothing
     Set myPath = Nothing
End Sub

3.API 方法

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
Declare Function GetDesktopWindow Lib "user32" () As Long

Public 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


Sub Sample3()
    Dim buf As String
    buf = GetFolder("请选择文件夹")
    If buf = "" Then Exit Sub
    MsgBox buf
End Sub


Function GetFolder(Optional Msg) As String
    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As Long, X As Long, pos As Integer
    bInfo.pidlRoot = 0&
    bInfo.lpszTitle = Msg
    bInfo.ulFlags = &H1
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    If R Then
        pos = InStr(pPath, Chr$(0))
        GetFolder = Left(pPath, pos - 1)
    Else
        GetFolder = ""
    End If
End Function