VBA中使用SHBrowseForFolder设置根目录与默认选中文件夹

以下是完整可运行的VBA代码，实现指定对话框根目录、默认选中并展开目标文件夹的需求，同时包含路径转PIDL的核心逻辑：

Option Explicit

' API声明
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListW" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
Private Declare PtrSafe Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As LongPtr, ByVal pbc As LongPtr, ByRef ppidl As LongPtr, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr) As Long
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

' 常量定义
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SETSELECTIONW As Long = &H400 + 103
Private Const S_OK As Long = 0

' 结构体定义
Private Type BROWSEINFO
    hWndOwner 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 Function BrowseCallbackProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal lParam As LongPtr, ByVal lpData As LongPtr) As LongPtr
    Dim targetPath As String
    targetPath = StrConv(VarPtrToString(lpData), vbUnicode)
    
    If uMsg = BFFM_INITIALIZED Then
        ' 发送消息设置默认选中并展开的文件夹
        Call SendMessage(hWnd, BFFM_SETSELECTIONW, 1, StrPtr(targetPath))
    End If
    
    BrowseCallbackProc = 0
End Function

' 将文件夹路径转换为PIDL
Private Function PathToPIDL(ByVal folderPath As String) As LongPtr
    Dim pidl As LongPtr
    Dim sfgaoOut As Long
    
    If SHParseDisplayName(StrPtr(folderPath), 0, pidl, 0, sfgaoOut) = S_OK Then
        PathToPIDL = pidl
    Else
        PathToPIDL = 0
    End If
End Function

' 主函数：显示文件夹选择对话框
Public Function ShowCustomFolderDialog(ByVal rootFolderPath As String, ByVal defaultSelectedPath As String, Optional ByVal dialogTitle As String = "选择文件夹") As String
    Dim bi As BROWSEINFO
    Dim pidlRoot As LongPtr
    Dim pidlResult As LongPtr
    Dim folderPath As String
    
    ' 转换根目录路径为PIDL
    pidlRoot = PathToPIDL(rootFolderPath)
    If pidlRoot = 0 Then
        MsgBox "指定的根目录路径无效", vbExclamation
        ShowCustomFolderDialog = ""
        Exit Function
    End If
    
    ' 初始化BROWSEINFO结构体
    With bi
        .hWndOwner = Application.hWnd
        .pidlRoot = pidlRoot
        .lpszTitle = dialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE
        .lParam = StrPtr(defaultSelectedPath) ' 传递默认选中路径到回调函数
        .lpfn = AddressOf BrowseCallbackProc ' 设置回调函数
    End With
    
    ' 显示对话框
    pidlResult = SHBrowseForFolder(bi)
    
    ' 释放根目录PIDL内存
    Call CoTaskMemFree(pidlRoot)
    
    ' 获取选中的文件夹路径
    If pidlResult <> 0 Then
        folderPath = String$(260, vbNullChar)
        If SHGetPathFromIDList(pidlResult, folderPath) Then
            ShowCustomFolderDialog = Left$(folderPath, InStr(folderPath, vbNullChar) - 1)
        End If
        ' 释放结果PIDL内存
        Call CoTaskMemFree(pidlResult)
    Else
        ShowCustomFolderDialog = ""
    End If
End Function

' 测试用例
Sub TestDialog()
    Dim selectedFolder As String
    ' 示例：根目录设为D:\，默认选中D:\Games\Steam
    selectedFolder = ShowCustomFolderDialog("D:\", "D:\Games\Steam", "请选择游戏文件夹")
    If selectedFolder <> "" Then
        MsgBox "选中的文件夹：" & selectedFolder, vbInformation
    Else
        MsgBox "未选择任何文件夹", vbInformation
    End If
End Sub

关键逻辑说明 #

• 路径转PIDL：通过SHParseDisplayNameAPI将文件夹路径转换为PIDL，这是Shell函数识别文件夹的核心标识。
• 回调函数：利用BrowseCallbackProc在对话框初始化完成后，发送BFFM_SETSELECTIONW消息，指定默认选中的文件夹路径，实现自动展开并选中目标文件夹。
• 内存管理：所有通过Shell API生成的PIDL必须用CoTaskMemFree释放，避免内存泄漏。
• 对话框样式：使用BIF_NEWDIALOGSTYLE启用现代对话框样式，BIF_RETURNONLYFSDIRS确保只返回文件系统目录。

使用说明 #

1. 将代码复制到VBA模块中（需启用"信任对VBA项目对象模型的访问"）。
2. 运行TestDialog子过程测试，可根据需求修改rootFolderPath和defaultSelectedPath参数。

内容的提问来源于stack exchange，提问作者darekk