VBA 瀏覽文件夾對話框調用實現代碼。大家可以根據需要選擇。
1、使用API方法
'【類型聲明】
Private Type BROWSEINFO
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
'【API聲明】
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function lstrcat Lib "kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Private Declare Function OleInitialize Lib "ole32.dll" _
(lp As Any) As Long
Private Declare Sub OleUninitialize Lib "ole32" ()
Private Const BIF_USENEWUI = &H40
Private Const MAX_PATH = 260
'【自定義函數】
Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim BInfo As BROWSEINFO
If IsMissing(vFlags) Then vFlags = BIF_USENEWUI
Call OleInitialize(ByVal 0&)
With BInfo
.lpszTitle = lstrcat(sTitle, "")
.ulFlags = vFlags
End With
lpIDList = SHBrowseForFolder(BInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
If sBuffer <> "" Then GetFolder_API = sBuffer
End If
Call OleUninitialize
End Function
'【使用方法】
Sub Test()
MsgBox GetFolder_API("選擇文件夾")
End Sub
2、使用Shell.Application方法
Sub GetFloder_Shell()
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "選擇文件夾", 0, 0)
If Not objFolder Is Nothing Then
MsgBox objFolder.self.path
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
3、使用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
以上方法在WINXP+OFFICE2003中測試通過