应用程序 Visual Basic/文件和文件夹对话框
有时我们需要访问文件和文件夹以提供过程的输入，以下代码将执行此操作。它们与 Windows 使用的对话框并没有太大区别，它们都通过返回所选项目的完整路径字符串来工作。当选择文件夹时，返回的字符串不包括末尾的反斜杠；用户需要自己添加。
两个对话框 ''SelectFolder()'' 和 ''SelectFile()'' 适用于 32 位和 64 位版本的 MS Office，但 API 过程 ''BrowseFolder()'' 不适用于 64 位工作；它仅在 32 位系统中工作。为了完整性，页面底部添加了另一个适用于 64 位系统的 API 版本。尽管这两个看起来有点相似，但为您的 MS Office 版本选择正确的版本很重要。所有三个都可以从测试过程运行。
只需将整个代码清单复制到标准模块中以供使用，并注释掉不需要的 API 版本（假设使用了 API）。
在 SelectFile() 中打开的默认文件类型列表由Filters.Add 代码行在序列中的出现顺序决定。例如，要将所有文件作为首选列表，只需将该行移到Filters Clear 行之后。当然，也可以在对话框打开时选择下拉菜单来更改列表。
Option Explicit
Option Private Module
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This API procedure is for 32 bit systems only; see below for a 64 bit API
' API version code credit to Chip Pearson at http://www.cpearson.com/excel/browsefolder.aspx
' This contains the BrowseFolder function, which displays the standard Windows Browse For Folder
' dialog. It returns the complete path of the selected folder or vbNullString if the user cancelled.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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 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
Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
BROWSEINFO) As Long
Private Const MAX_PATH = 260 ' Windows mandated
Sub TestBrowseFilesAndFolders()
Dim sRet As String
'run to test the file selection dialog
sRet = SelectFile("Select a file...")
'run to test the folder selection dialog
'sRet = SelectFolder("Select a folder...")
'run to test the API folder selection dialog
'sRet = BrowseFolder("Select a folder...")
MsgBox sRet
End Sub
Function BrowseFolder(Optional ByVal DialogTitle As String = "") As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolder
' This displays the standard Windows Browse Folder dialog. It returns
' the complete path name of the selected folder or vbNullString if the
' user cancelled. Returns without and end backslash.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If DialogTitle = vbNullString Then
DialogTitle = "Select A Folder..."
End If
Dim uBrowseInfo As BROWSEINFO
Dim szBuffer As String
Dim lID As Long
Dim lRet As Long
With uBrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = DialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI
.lpfn = 0
End With
szBuffer = String$(MAX_PATH, vbNullChar)
lID = SHBrowseForFolderA(uBrowseInfo)
If lID Then
''' Retrieve the path string.
lRet = SHGetPathFromIDListA(lID, szBuffer)
If lRet Then
BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
End If
End If
End Function
Function SelectFolder(Optional sTitle As String = "") As String
'opens a file-select dialog and on selection
'returns its full path string in the function name
'If Cancel or OK without selection, returns empty string
'Returns path string without an end backslash.
Dim sOut As String
With Application.FileDialog(msoFileDialogFolderPicker)
'see also msoFileDialogFolderPicker, msoFileDialogOpen, and msoFileDialogSaveAs
'uses Excel's default opening path but any will do
'needs the backslash in this case
.InitialFileName = Application.DefaultFilePath & " \ "
.Title = sTitle
.Show
If .SelectedItems.Count = 0 Then
'MsgBox "Canceled without selection"
Else
sOut = .SelectedItems(1)
'MsgBox sOut
End If
End With
SelectFolder = sOut
End Function
Function SelectFile(Optional sTitle As String = "") As String
'opens a file-select dialog and on selection
'returns its full path string in the function name
'If Cancel or OK without selection, returns empty string
Dim fd As FileDialog, sPathOnOpen As String, sOut As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'do not include backslash here
sPathOnOpen = Application.DefaultFilePath
'set the file-types list on the dialog and other properties
With fd
.Filters.Clear
.Filters.Add "Excel workbooks", "*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
.Filters.Add "Word documents", "*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
.Filters.Add "All Files", "*.*"
.AllowMultiSelect = False
.InitialFileName = sPathOnOpen
.Title = sTitle
.InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
.Show
If .SelectedItems.Count = 0 Then
'MsgBox "Canceled without selection"
Exit Function
Else
sOut = .SelectedItems(1)
'MsgBox sOut
End If
End With
SelectFile = sOut
End Function
Option Explicit
Option Compare Text
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As LongPtr, ByVal pszPath As String) As Long
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As LongPtr
Private Const BIF_RETURNONLYFSDIRS = &H1
Sub a_testBrowseFolder2()
'Tests the 64 bit version of the API BrowsFolder2
Dim sFPath As String
sFPath = BrowseFolder2("Please select a folder.")
MsgBox sFPath
End Sub
Public Function BrowseFolder2(Optional sTitle As String = "") As String
'This version of the BrowsFolder API is for 64 bit systems. For 32 bit systems use one at top of page
'This function returns a folder path string as selected in the browse dialog, without a trailing backslash.
'Credit is given to Peter De Baets, from which this procedure was trimmed for 64 bit only.
Dim x As Long, Dlg As BROWSEINFO
Dim DlgList As LongPtr
Dim sPath As String, Pos As Integer
Dim sRet As String
sRet = ""
With Dlg
'.hOwner = hWndAccessApp 'errors
.lpszTitle = sTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
DlgList = SHBrowseForFolder(Dlg)
sPath = Space$(512)
x = SHGetPathFromIDList(ByVal DlgList, ByVal sPath)
If x Then
Pos = InStr(sPath, Chr(0))
sRet = Left$(sPath, Pos - 1)
Else
sRet = ""
End If
BrowseFolder2 = sRet
End Function
- BrowseFolder : Chip Pearson 关于 API 文件夹浏览器的页面。
- FileDialog 属性和方法: Microsoft 对 FileDialog 选择方法的文档。它包括一个代码面板，显示了使用文件多选的方法。