如何让VBA等待ShellExecute完成以同步Outlook邮件及附件打印

这问题我之前也碰到过！ShellExecute的异步特性确实会让打印任务互相插队，要实现同步打印（等当前任务完成再继续下一个），用CreateProcess配合Windows API的进程等待函数就能搞定，下面给你一步步讲怎么实现：

核心思路 #

ShellExecute启动打印进程后会立刻返回，VBA不会等它执行完；而CreateProcess可以获取到进程的句柄，再用WaitForSingleObject函数等待这个进程结束，就能保证打印任务按顺序执行。

第一步：声明需要的Windows API #

因为VBA本身没有这些函数，得先声明（注意区分32位和64位Office，不然会报错）：

#If VBA7 Then
    Private Declare PtrSafe Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessA" ( _
        ByVal lpApplicationName As String, _
        ByVal lpCommandLine As String, _
        ByVal lpProcessAttributes As LongPtr, _
        ByVal lpThreadAttributes As LongPtr, _
        ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, _
        ByVal lpEnvironment As LongPtr, _
        ByVal lpCurrentDirectory As String, _
        lpStartupInfo As STARTUPINFO, _
        lpProcessInformation As PROCESS_INFORMATION) As Long
        
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32.dll" ( _
        ByVal hHandle As LongPtr, _
        ByVal dwMilliseconds As Long) As Long
        
    Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" ( _
        ByVal hObject As LongPtr) As Long
        
    Private Type STARTUPINFO
        cb As Long
        lpReserved As String
        lpDesktop As String
        lpTitle As String
        dwX As Long
        dwY As Long
        dwXSize As Long
        dwYSize As Long
        dwXCountChars As Long
        dwYCountChars As Long
        dwFillAttribute As Long
        dwFlags As Long
        wShowWindow As Integer
        cbReserved2 As Integer
        lpReserved2 As LongPtr
        hStdInput As LongPtr
        hStdOutput As LongPtr
        hStdError As LongPtr
    End Type
    
    Private Type PROCESS_INFORMATION
        hProcess As LongPtr
        hThread As LongPtr
        dwProcessId As Long
        dwThreadId As Long
    End Type
#Else
    Private Declare Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessA" ( _
        ByVal lpApplicationName As String, _
        ByVal lpCommandLine As String, _
        ByVal lpProcessAttributes As Long, _
        ByVal lpThreadAttributes As Long, _
        ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, _
        ByVal lpEnvironment As Long, _
        ByVal lpCurrentDirectory As String, _
        lpStartupInfo As STARTUPINFO, _
        lpProcessInformation As PROCESS_INFORMATION) As Long
        
    Private Declare Function WaitForSingleObject Lib "kernel32.dll" ( _
        ByVal hHandle As Long, _
        ByVal dwMilliseconds As Long) As Long
        
    Private Declare Function CloseHandle Lib "kernel32.dll" ( _
        ByVal hObject As Long) As Long
        
    Private Type STARTUPINFO
        cb As Long
        lpReserved As String
        lpDesktop As String
        lpTitle As String
        dwX As Long
        dwY As Long
        dwXSize As Long
        dwYSize As Long
        dwXCountChars As Long
        dwYCountChars As Long
        dwFillAttribute As Long
        dwFlags As Long
        wShowWindow As Integer
        cbReserved2 As Integer
        lpReserved2 As Long
        hStdInput As Long
        hStdOutput As Long
        hStdError As Long
    End Type
    
    Private Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadId As Long
    End Type
#End If

Private Const INFINITE As Long = &HFFFFFFFF
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const SW_HIDE As Integer = 0

第二步：写一个同步打印的函数 #

这个函数会调用CreateProcess启动打印，然后等待进程结束：

Sub PrintFileSync(ByVal filePath As String)
    Dim si As STARTUPINFO
    Dim pi As PROCESS_INFORMATION
    Dim cmdLine As String
    Dim success As Long
    
    ' 设置启动信息：隐藏窗口（避免弹出打印程序界面）
    si.cb = Len(si)
    si.dwFlags = STARTF_USESHOWWINDOW
    si.wShowWindow = SW_HIDE
    
    ' 构建打印命令行：用默认程序打印指定文件
    cmdLine = "cmd /c """ & filePath & """"
    
    ' 启动打印进程
    success = CreateProcess(vbNullString, cmdLine, 0, 0, 1, 0, 0, vbNullString, si, pi)
    
    If success <> 0 Then
        ' 等待进程结束（无限等待，直到打印完成）
        WaitForSingleObject pi.hProcess, INFINITE
        ' 释放进程和线程句柄，避免内存泄漏
        CloseHandle pi.hThread
        CloseHandle pi.hProcess
    Else
        MsgBox "打印启动失败：" & filePath, vbExclamation
    End If
End Sub

第三步：结合Outlook场景使用 #

现在你可以在遍历邮件和附件的代码里，用这个PrintFileSync代替原来的ShellExecute，就能保证顺序打印：

Sub PrintOutlookItemsWithAttachments()
    Dim objFolder As Outlook.Folder
    Dim objItem As Object
    Dim objAttachment As Outlook.Attachment
    Dim tempPath As String
    
    ' 获取要打印的Outlook文件夹（这里示例选收件箱，你可以改成自己的文件夹）
    Set objFolder = Application.Session.GetDefaultFolder(olFolderInbox)
    
    ' 遍历文件夹中的每个邮件
    For Each objItem In objFolder.Items
        If objItem.Class = olMail Then
            ' 先打印邮件本身
            objItem.PrintOut
            
            ' 遍历邮件的附件
            For Each objAttachment In objItem.Attachments
                ' 判断附件格式：Excel、Word、PDF
                Select Case LCase(Right(objAttachment.FileName, 4))
                    Case ".xls", ".xlsx", ".doc", ".docx", ".pdf"
                        ' 先把附件保存到临时目录（因为直接打印附件需要本地文件）
                        tempPath = Environ("TEMP") & "\" & objAttachment.FileName
                        objAttachment.SaveAsFile tempPath
                        
                        ' 同步打印附件
                        PrintFileSync tempPath
                        
                        ' 删除临时文件（可选，根据需求决定）
                        Kill tempPath
                End Select
            Next objAttachment
        End If
    Next objItem
    
    MsgBox "打印任务全部完成！", vbInformation
End Sub

关键细节说明 #

1. 进程等待：WaitForSingleObject pi.hProcess, INFINITE会一直阻塞VBA代码，直到打印进程结束，这样就不会出现任务混杂的情况。
2. 32/64位兼容：开头的#If VBA7 Then判断保证代码在32位和64位Office上都能运行。
3. 临时文件：Outlook附件需要先保存到本地才能打印，用完可以删除避免占用空间。

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