如何在VBA中无弹窗自动打印Outlook邮件及附件至PDF？

环境 #

• Windows 10
• Microsoft 365、Outlook v.2205

问题 #

需要编写一个宏，自动将选中的邮件及附件打印为PDF，全程无需用户干预。但使用MailItem.PrintOut命令时会弹出打印对话框，导致宏停滞，必须手动操作才能继续。

目前已通过Word对象库实现邮件正文的无对话框打印，但PDF等附件的无干扰打印尚无纯原生VBA解决方案。尝试过用API/VBA操控打印对话框，但发现对话框弹出后VBA会暂停运行，因此必须彻底绕过对话框。

附当前简化代码：

Private Sub printEmail()

    Dim mySelection As Outlook.Selection
    Dim myEmail As MailItem

    Set mySelection = Application.ActiveExplorer.Selection

    ' 如果选中的是邮件项则执行打印
    If mySelection.Item(1).Class = 43 Then
        Set myEmail = mySelection.Item(1)
        
        myEmail.PrintOut ' <===###此命令会弹出打印对话框###
    
    ' 否则退出子程序
    Else
        MsgBox "请选择邮件项"
        Exit Sub
    End If

End Sub

解决方案 #

核心思路 #

1. 提前将Microsoft Print to PDF设置为系统默认打印机，确保打印输出为PDF格式
2. 用Word对象库打开邮件正文，指定打印机并静默打印，绕过对话框
3. 遍历邮件附件，针对PDF附件使用ShellExecuteAPI实现无对话框打印，其他可打印附件（如Word文档）用对应对象库处理

完整实现代码 #

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
    ByVal hWnd As LongPtr, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Private Sub PrintEmailAndAttachmentsToPDF()
    Dim mySelection As Outlook.Selection
    Dim myEmail As MailItem
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim tempPath As String
    Dim attach As Attachment
    Dim printResult As LongPtr
    
    Set mySelection = Application.ActiveExplorer.Selection
    
    ' 检查选中项是否为邮件
    If mySelection.Count = 0 Or mySelection.Item(1).Class <> 43 Then
        MsgBox "请选择单个邮件项"
        Exit Sub
    End If
    Set myEmail = mySelection.Item(1)
    
    tempPath = Environ("TEMP") & "\"
    
    ' 1. 打印邮件正文到PDF
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    Set wordDoc = wordApp.Documents.Open(myEmail.Body) ' 也可使用myEmail.GetInspector.WordEditor直接获取正文
    
    ' 指定打印机为Microsoft Print to PDF，静默打印
    wordDoc.Application.ActivePrinter = "Microsoft Print to PDF"
    wordDoc.PrintOut Background:=False, PrintToFile:=False, Prompt:=False
    
    wordDoc.Close SaveChanges:=False
    wordApp.Quit
    Set wordDoc = Nothing
    Set wordApp = Nothing
    
    ' 2. 打印PDF附件到PDF
    For Each attach In myEmail.Attachments
        ' 仅处理PDF附件
        If LCase(Right(attach.FileName, 4)) = ".pdf" Then
            attach.SaveAsFile tempPath & attach.FileName
            ' 静默打印PDF文件
            printResult = ShellExecute(0, "print", tempPath & attach.FileName, "", tempPath, 0)
            ' 等待打印完成（可根据附件大小调整延迟时长）
            Application.Wait Now + TimeValue("00:00:02")
            ' 删除临时文件
            Kill tempPath & attach.FileName
        End If
    Next attach
    
    MsgBox "邮件及附件已完成PDF打印"
End Sub

注意事项 #

• 确保Microsoft Print to PDF打印机已安装并设置为默认打印机，也可在代码中直接指定打印机名称（需与系统显示名称完全一致）
• 对于非PDF类型的附件，可根据文件类型扩展对应处理逻辑（如Excel文档用Excel对象库打开打印）
• ShellExecute的延迟时间可根据附件大小调整，避免文件未保存完成就触发打印

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