Outlook VBA调用Adobe PDF打印邮件时自动操作PDF保存对话框方法

原有代码失效的核心原因有两点：

• MailItem.PrintOut 是异步执行方法，调用后Adobe PDF的保存对话框需要1-3秒完成加载，直接执行AppActivate时对话框尚未就绪，焦点会停留在前台的VBE编辑器窗口
• SendKeys 强依赖前台窗口焦点，执行过程中任意窗口抢占焦点都会导致操作失败

不需要激活窗口、不需要模拟按键，通过Windows API直接定位对话框控件，写入完整保存路径、触发保存按钮即可，全程不受VBE窗口干扰，稳定性远高于SendKeys方案。

实现步骤 #

1. 在VBA模块的最顶部（所有过程之外）添加如下API声明，兼容32位、64位版本的Office：

' Windows API声明 兼容32/64位Office
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 GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' 对话框常量定义
Private Const WM_SETTEXT = &HC
Private Const BM_CLICK = &HF5
Private Const SAVEBTN_CTRL_ID = 1

2. 替换原有代码中「Print/save email as PDF」部分的逻辑，修改后的代码段如下：

'================================================================================
' Print/save email as PDF
'================================================================================
    Dim fullSavePath As String
    Dim hDlg As LongPtr, hFileNameInput As LongPtr, hSaveBtn As LongPtr
    Dim waitCount As Long, originalPrinter As Object
    Const MAX_WAIT_MS = 10000 ' 对话框最大等待时长10秒
    
    ' 拼接PDF完整保存路径（必须带.pdf后缀）
    fullSavePath = olTempFolder & "\" & myDate & ".pdf"
    
    ' 记录当前默认打印机，操作完成后恢复
    Set mynetwork = CreateObject("WScript.Network")
    originalPrinter = mynetwork.defaultprinter
    
    ' 设置Adobe PDF为默认打印机并触发打印
    mynetwork.setdefaultprinter myPrinter
    myItem.PrintOut
    
    ' 循环等待保存对话框加载完成
    waitCount = 0
    Do While hDlg = 0
        hDlg = FindWindow("#32770", myDialogueTitle)
        If hDlg <> 0 Then Exit Do
        Sleep 100
        waitCount = waitCount + 100
        If waitCount >= MAX_WAIT_MS Then
            mynetwork.setdefaultprinter originalPrinter
            MsgBox "等待PDF保存对话框超时，请检查Adobe Acrobat运行状态"
            Exit Sub
        End If
    Loop
    
    ' 向文件名输入框直接写入完整保存路径
    hFileNameInput = FindWindowEx(hDlg, 0, "Edit", vbNullString)
    SendMessage hFileNameInput, WM_SETTEXT, 0, ByVal fullSavePath
    
    ' 触发保存按钮点击
    hSaveBtn = GetDlgItem(hDlg, SAVEBTN_CTRL_ID)
    Sleep 200 ' 等待路径写入完成
    SendMessage hSaveBtn, BM_CLICK, 0, 0
    
    ' 保存完成后恢复原默认打印机
    Sleep 1000
    mynetwork.setdefaultprinter originalPrinter

注意事项 #

• 该方案不依赖窗口前台焦点，代码运行时即使VBE窗口处于前台，也能正常操作Adobe保存对话框，不会出现焦点抢占问题
• 直接写入完整绝对路径时，系统对话框会自动定位到对应目录，不需要单独模拟路径切换操作，逻辑更稳定
• 代码运行时尽量不要手动操作Office窗口，避免打印进程被系统中断
• 该方案全程未调用Outlook的.SaveAs方法，符合环境限制要求。

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