如何在Application.FileDialog(msoFileDialogFilePicker)中自动选中文件夹所有文件

问题背景 #

需要通过Application.FileDialog(msoFileDialogFilePicker)实现：导航到指定文件夹后，自动选中（高亮）该文件夹内所有符合过滤规则的文件，同时自动填充对话框的文件名文本框（效果等同于手动选中多个文件）。

尝试了以下代码，但InitialFileName未生效，手动输入多文件名也会报错：

Sub SelectAllFilesInFolder()
Dim fd As FileDialog
Dim vSelectedItems As Variant
Const sPath As String = "C:\Users\somefolder\"
Dim sFileString As Variant
Dim vFiles As Variant
Dim FileColl As Collection

With ThisWorkbook
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Filters.Add "Word Files", "*.doc*", 1
        .InitialFileName = sPath
        .ButtonName = "Select"
        sFileString = sPath & Chr(31) & "France - Charlotte.docx" & Chr(31) & " " & Chr(31) & "France - Fabienne.docx" & Chr(31)
        .InitialFileName = sFileString
                
        If .Show = -1 Then
           ' some processing code    
        End If
        
    End With

End With
End Sub

问题原因 #

InitialFileName属性仅支持设置初始文件夹路径或单个文件名，无法通过拼接特殊分隔符来预设选中多个文件，这是代码失效的核心原因。对话框本身也不接受手动输入多文件名的格式，因此会报错。

解决方案 #

方法1：SendKeys快捷键全选（简单易实现）

利用Ctrl+A快捷键在对话框显示后自动选中所有符合过滤条件的文件，适合简单场景：

Sub SelectAllFilesInFolder()
    Dim fd As FileDialog
    Const sPath As String = "C:\Users\somefolder\"
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Filters.Add "Word Files", "*.doc*", 1
        .InitialFileName = sPath
        .ButtonName = "Select"
        
        ' 延迟1秒发送Ctrl+A，确保对话框已加载完成
        Application.OnTime Now + TimeValue("00:00:01"), "SendCtrlA"
        
        If .Show = -1 Then
            ' 处理选中的文件示例
            Dim i As Integer
            For i = 1 To .SelectedItems.Count
                Debug.Print "选中文件：" & .SelectedItems(i)
            Next i
        End If
    End With
    Set fd = Nothing
End Sub

' 发送Ctrl+A快捷键的辅助过程
Sub SendCtrlA()
    SendKeys "^a", True
End Sub

注意：如果对话框加载较慢，可调整延迟时间（比如TimeValue("00:00:02")），SendKeys的稳定性受系统环境影响。

方法2：Windows API精准选中（稳定可靠）

通过API获取对话框窗口句柄，直接操作文件列表控件选中所有文件，不受界面延迟影响：

' 64位Office API声明（32位需移除PtrSafe，将LongPtr改为Long）
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As LongPtr, ByVal dwStackSize As LongPtr, ByVal lpStartAddress As LongPtr, lpParameter As Any, ByVal dwCreationFlags As Long, ByRef lpThreadId As Long) As LongPtr

Private Const LB_SETSEL = &H185
Private Const LB_GETCOUNT = &H18B
Private Const LVM_SETITEMSTATE = &H103E
Private Const LVM_GETITEMCOUNT = &H1004
Private Const LVIS_SELECTED = &H2

Sub SelectAllFilesWithAPI()
    Dim fd As FileDialog
    Const sPath As String = "C:\Users\somefolder\"
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Filters.Add "Word Files", "*.doc*", 1
        .InitialFileName = sPath
        .ButtonName = "Select"
        
        ' 创建线程等待对话框加载并执行选中操作
        Dim threadID As Long
        CreateThread AddressOf WaitAndSelectFiles, 0, 0, 0, 0, threadID
        
        If .Show = -1 Then
            ' 处理选中的文件示例
            Dim i As Integer
            For i = 1 To .SelectedItems.Count
                Debug.Print "选中文件：" & .SelectedItems(i)
            Next i
        End If
    End With
    Set fd = Nothing
End Sub

Private Function WaitAndSelectFiles() As Long
    Dim dialogHwnd As LongPtr
    Dim listHwnd As LongPtr
    Dim itemCount As LongPtr
    Dim i As Long
    
    ' 等待对话框窗口出现（中文环境标题为"选择"，英文为"Select"）
    Do
        dialogHwnd = FindWindow("#32770", "选择")
        DoEvents
    Loop Until dialogHwnd <> 0
    
    ' 获取文件列表控件句柄（不同Office版本可能是SysListView32或ListBox）
    listHwnd = FindWindowEx(dialogHwnd, 0, "SysListView32", vbNullString)
    If listHwnd = 0 Then
        listHwnd = FindWindowEx(dialogHwnd, 0, "ListBox", vbNullString)
    End If
    
    If listHwnd <> 0 Then
        ' 区分ListBox和ListView控件的选中逻辑
        If InStr(GetClassName(listHwnd), "ListBox") > 0 Then
            ' ListBox控件：选中所有项
            itemCount = SendMessage(listHwnd, LB_GETCOUNT, 0, 0)
            SendMessage listHwnd, LB_SETSEL, True, ByVal -1&
        ElseIf InStr(GetClassName(listHwnd), "SysListView32") > 0 Then
            ' ListView控件：逐个选中所有项
            itemCount = SendMessage(listHwnd, LVM_GETITEMCOUNT, 0, 0)
            For i = 0 To itemCount - 1
                SendMessage listHwnd, LVM_SETITEMSTATE, i, ByVal LVIS_SELECTED
            Next i
        End If
    End If
    
    WaitAndSelectFiles = 0
End Function

' 获取控件类名的辅助API
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Function GetClassName(hWnd As LongPtr) As String
    Dim className As String * 256
    GetClassName hWnd, className, 256
    GetClassName = Left(className, InStr(className, vbNullChar) - 1)
End Function

注意：

• 对话框标题需匹配你的Office语言（中文用"选择"，英文用"Select"）
• API声明需对应Office位数（32位/64位），代码中是64位版本

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