應用程式 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 選擇方法的文件。它包括一個程式碼面板，顯示了使用檔案多選的方法。