|
在VBA中可以用Application对象的GetOpenFilename方法来调用打开文件对话框，但Excel却没有提供浏览文件夹的方法。我们可以用下面的两种方法来调用浏览文件夹对话框。
方法一：用Windows API 函数，在标准模块中自定义一个函数BrowseFolderA，然后在过程中调用：
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszINSTRUCTIONS As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
lpBrowseInfo As BrowseInfo) As Long
Function BrowseFolderA(Optional Caption As String = "") As String
Dim BrowseInfo As BrowseInfo
Dim FolderName As String
Dim ID As Long
Dim Res As Long
With BrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = Caption
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = 0
End With
FolderName = String$(MAX_PATH, vbNullChar)
ID = SHBrowseForFolderA(BrowseInfo)
If ID Then
Res = SHGetPathFromIDListA(ID, FolderName)
If Res Then
BrowseFolderA = Left$(FolderName, InStr(FolderName, vbNullChar) - 1)
End If
End If
End Function
下面是调用BrowseFolderA函数的代码示例：
Sub BrowseFolder_A()
Dim FName As String
FName = BrowseFolderA(Caption:="选择一个文件夹")
If FName = vbNullString Then
Debug.Print "没有选择文件夹"
Else
Debug.Print "选择的文件夹是： " & FName
End If
End Sub
方法二：用Shell控件库。在使用这个方法前，必需在VBA中调用“Microsoft Shell Controls And Automation”库，方法是在VBA编辑器中单击菜单“工具→引用”，在“引用”窗口中选择“Microsoft Shell Controls And Automation”，单击“确定”。
然后，将下面的代码输入到标准模块中。
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Function BrowseFolderB(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolderB = F.Items.Item.Path
End If
End Function
最后，用类似下面的代码进行调用：
Sub BrowseFolder_B()
Dim FName As String
FName = BrowseFolderB(Caption:="选择一个文件夹", InitialFolder:="")
If FName = vbNullString Then
Debug.Print "没有选择文件夹"
Else
Debug.Print "选择的文件夹是： " & FName
End If
End Sub
可以看到，这种方法调用的浏览文件夹对话框中多了一个“新建文件夹”按钮，并且可以拖动窗口的右下角来调整对话框的大小 |