李可五生饮指哪些:Excel中调用VBA选择目标文件夹

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

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

   1.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

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

4.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 Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _

                             (ByVal hWnd As Long, ByVal wMsg As Long, _

                              ByVal wParam As Long, lParam As Any) As Long

Public Const WM_USER = &H400

Public Const BFFM_SETSelectIONA = (WM_USER + 102)

Public Const BFFM_INITIALIZED = 1

Public Type BROWSEINFO

    hOwner As Long

    pidlRoot As Long

    pszDisplayName As String

    lpszTitle As String

    ulFlags As Long

    lpfn As Long

    lParam As String

    iImage As Long

End Type

Sub Sample4()

    Dim buf As String

    buf = GetDirectory("请选择文件夹", "G:\Downloads")

    If buf = "" Then

        Exit Sub

    Else

        MsgBox buf

    End If

End Sub

Function GetDirectory(Optional Msg, Optional UserPath) As String

    Dim bInfo As BROWSEINFO, pPath As String

    Dim R As Long, X As Long, pos As Integer

    With bInfo

        .pidlRoot = &H0

        .lpszTitle = Msg

        .ulFlags = &H40

        .lpfn = FARPROC(AddressOf BrowseCallbackProc)

        If IsMissing(UserPath) Then

            .lParam = CurDir & Chr(0)

        Else

            .lParam = UserPath & Chr(0)

        End If

    End With

    X = SHBrowseForFolder(bInfo)

    pPath = Space$(512)

    R = SHGetPathFromIDList(ByVal X, ByVal pPath)

    CoTaskMemFree X

    If R Then

        pos = InStr(pPath, Chr(0))

        GetDirectory = Left(pPath, pos - 1)

    Else

        GetDirectory = ""

    End If

End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _

                                                                           lParam As Long, ByVal lpData As Long) As Long

    If uMsg = BFFM_INITIALIZED Then

        SendMessage hWnd, BFFM_SETSelectIONA, 1, ByVal lpData

    End If

End Function

Public Function FARPROC(pfn As Long) As Long

    FARPROC = pfn

End Function