进行文件操作时,经常要用 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 |
|
来自: COPY&PASTE > 《excel vba》