excel在VBA中获取浏览文件夹对话框

来源:转载

在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

可以看到,这种方法调用的浏览文件夹对话框中多了一个“新建文件夹”按钮,并且可以拖动窗口的右下角来调整对话框的大小

分享给朋友:
您可能感兴趣的文章:
随机阅读: