VBA首次调用FileDialog时SendKeys失效问题求助

背景 #

我已完成四分之三的开发目标：开发了一款VBA程序，可根据用户此前选择的文件夹名称，自动生成带附件的邮件。

由于附件会随环境动态变化，且工作簿位于SharePoint上无法使用FileSystemObject，因此我通过FileDialog定位指定文件夹并全选文件，实现全自动化（仅会短暂闪烁）。

核心代码片段 #

'folderName is identified earlier
Dim files As FileDialog
Dim vrtSelectedItem As Variant
Dim list As String, wbName As String, atmpt As Long

wbName = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "/")) & _
         "Registry/Joining Instructions/" & folderName & "/"

Do
   Set files = Application.FileDialog(msoFileDialogFilePicker)
   cnt = 0
   atmpt = atmpt + 1
        
   With files
       .InitialFileName = wbName

       Application.SendKeys "+{TAB}", True
       Application.SendKeys "+{TAB}", True
       Application.SendKeys "^a", True
       Application.SendKeys "~", True
                    
       If .Show = -1 Then
            'Code continues...

问题 #

首次调用FileDialog时，SendKeys指令完全不生效；但后续所有调用（包括重新执行子程序）都能正常打开对话框、定位文件夹、全选附件并关闭。

想搞清楚：首次实例的FileDialog与后续实例存在什么差异？如何让首次调用也能正常执行SendKeys？

原因与解决方案 #

差异原因 #

首次调用FileDialog时，Office应用需要完成对话框的初始化流程——包括UI渲染、窗口焦点绑定、资源加载等，这个过程比后续调用慢很多。而SendKeys是即时发送按键指令的，首次调用时对话框还没完全获取焦点，导致按键指令被发送到了Excel主窗口而非FileDialog，自然没效果。后续调用时，对话框的相关资源已经被缓存，加载速度快，能及时获取焦点接收SendKeys指令。

解决办法 #

1. 添加延迟等待（最简单的临时方案）

在调用.Show之前加一段短暂延迟，给FileDialog足够的初始化时间，确保它获取焦点后再发送按键。可以用系统API的Sleep函数，或者纯VBA循环等待：

' 先在模块顶部声明Sleep API（区分32/64位Office）
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

' 在With块中修改代码：
With files
    .InitialFileName = wbName
    Sleep 200 ' 等待200毫秒，可根据实际情况调整（比如100-500ms）
    Application.SendKeys "+{TAB}", True
    Application.SendKeys "+{TAB}", True
    Application.SendKeys "^a", True
    Application.SendKeys "~", True
    
    If .Show = -1 Then
        ' 后续代码...
    End If
End With

如果不想用API，也可以用纯VBA循环：

With files
    .InitialFileName = wbName
    ' 等待0.2秒
    Dim startTime As Double
    startTime = Timer
    Do While Timer < startTime + 0.2
        DoEvents ' 避免程序假死，让系统处理事件
    Loop
    ' 再发送按键
    Application.SendKeys "+{TAB}", True
    ' ...后续SendKeys代码
End With

2. 用API强制获取对话框焦点（更可靠）

通过Windows API找到FileDialog的窗口句柄，强制将焦点切换到对话框后再发送SendKeys，彻底解决焦点问题：

' 模块顶部声明API
#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
#End If

' 主程序代码调整
With files
    .InitialFileName = wbName
    ' 延迟执行SendKeys，避免阻塞对话框显示
    Application.OnTime Now + TimeValue("00:00:00.2"), "SendKeysToFileDialog"
    If .Show = -1 Then
        ' 后续代码...
    End If
End With

' 单独的SendKeys子程序
Sub SendKeysToFileDialog()
    ' 查找FileDialog窗口（中文Office标题是"文件选取器"，英文是"File Picker"）
    Dim hWnd As LongPtr
    hWnd = FindWindow("#32770", "文件选取器")
    If hWnd <> 0 Then
        SetForegroundWindow hWnd ' 强制焦点到对话框
        ' 发送按键指令
        Application.SendKeys "+{TAB}", True
        Application.SendKeys "+{TAB}", True
        Application.SendKeys "^a", True
        Application.SendKeys "~", True
    End If
End Sub

3. 彻底抛弃SendKeys（最优方案）

SendKeys本身就依赖系统状态和窗口焦点，稳定性差。既然是SharePath路径，直接用SharePoint对象模型获取文件列表，直接添加附件，完全绕过FileDialog：

Dim spSite As Object
Dim spFolder As Object
Dim spFile As Object

' 创建SharePoint对象
Set spSite = CreateObject("SharePoint.OpenDocuments.3")
' 获取目标文件夹
Set spFolder = spSite.GetFolder(wbName)

' 遍历文件夹内所有文件，添加为邮件附件
For Each spFile In spFolder.Files
    ' 假设你的邮件对象是mail，根据实际代码调整
    mail.Attachments.Add spFile.Path
Next

Set spFile = Nothing
Set spFolder = Nothing
Set spSite = Nothing

注意：这个方法需要用户有权限访问目标SharePoint站点，且路径格式必须正确（确保wbName是有效的SharePoint文件夹路径）。

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