Outlook VBA邮件转PDF遇运行时错误5及文件错误的排查需求

问题背景 #

现有Outlook VBA脚本用于监控「Receipts With Tax」文件夹：邮件移入时自动转换为PDF，保存到指定路径后，将邮件移至「Receipts」文件夹。该脚本在一台机器正常运行，另一台机器出现以下错误：

• 错误A：保存MHT文件时提示「文件错误」，原因是临时文件已被打开或宏提前终止，重启Windows可解决，但需代码层面处理该问题
• 错误B：重启后执行SaveAsPDFfile()子程序时，出现「无效的过程调用或参数 - 错误5」

错误原因分析 #

错误A #

1. 临时MHT文件名固定，若宏意外终止，文件未被删除，后续执行时会因文件被占用报错
2. FolderChange事件可能因文件夹内容变动多次触发，导致多个进程同时操作同一临时文件
3. 未检查目标PDF文件夹是否存在，若路径不存在会触发文件操作错误

错误B #

1. 使用了Word的命名常量（如wdExportFormatPDF），但代码采用Late Binding（CreateObject("Word.Application")），未定义这些常量，导致参数值无效
2. Word进程未正常关闭，残留进程占用资源导致后续调用失败
3. 邮件转换为MHT后，Word打开文件时可能存在格式兼容性问题

修复后的完整代码 #

' 功能：Receipts With Tax文件夹邮件转PDF后移动到Receipts文件夹
Const Receipts_With_Tax As String = "Receipts With Tax"
Const Receipts As String = "Receipts"
Const pdfPath As String = "C:\Users\MBA\Desktop\PDFs\"

' Word导出常量（Late Binding需手动定义）
Const wdExportFormatPDF As Long = 17
Const wdExportOptimizeForPrint As Long = 0
Const wdExportAllDocument As Long = 0
Const wdExportDocumentContent As Long = 0
Const wdExportCreateNoBookmarks As Long = 0

Public WithEvents Receipts_With_Tax_FOLDER As Outlook.Folder ' 修改为监控单个文件夹，避免多次触发

Private Sub Application_Startup()
    Dim MyNS As NameSpace
    Set MyNS = Application.GetNamespace("MAPI")
    ' 直接绑定目标文件夹，而非所有子文件夹
    Set Receipts_With_Tax_FOLDER = MyNS.Folders(1).Folders(Receipts_With_Tax)
End Sub

Private Sub Receipts_With_Tax_FOLDER_ItemAdd(ByVal Item As Object)
    ' 使用ItemAdd事件替代FolderChange，仅当有新邮件移入时触发
    If TypeOf Item Is Outlook.MailItem Then
        sTaxReceipts_2_Receipts Item
    End If
End Sub

Sub sTaxReceipts_2_Receipts(iMail As Outlook.MailItem)
    Dim MyNS As Outlook.NameSpace
    Dim olFolderReceipts As Outlook.Folder
    Dim MyPath As String
    Dim FSO As Object
    
    Set FSO = CreateObject("scripting.filesystemobject")
    ' 检查PDF保存路径是否存在，不存在则创建
    If Not FSO.FolderExists(pdfPath) Then
        FSO.CreateFolder pdfPath
    End If
    
    Set MyNS = Application.GetNamespace("MAPI")
    Set olFolderReceipts = MyNS.Folders(1).Folders(Receipts)
    
    ' 生成唯一PDF文件名，避免冲突
    MyPath = pdfPath & Replace(iMail.SenderEmailAddress, "@", "_") & "_" & Format(iMail.ReceivedTime, "yyyy-mm-dd_hhmmss") & ".pdf"
    
    ' 添加错误处理，避免转换失败导致邮件未移动
    On Error Resume Next
    SaveAsPDFfile iMail, MyPath
    If Err.Number = 0 Then
        iMail.Move olFolderReceipts
    Else
        ' 可选：记录错误日志
        Debug.Print "转换失败：" & Err.Description & "，邮件主题：" & iMail.Subject
    End If
    On Error GoTo 0
    
    ' 清理对象
    Set olFolderReceipts = Nothing
    Set MyNS = Nothing
    Set FSO = Nothing
End Sub

Sub SaveAsPDFfile(objItem As Outlook.MailItem, MyPath As String)
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Dim FSO As Object
    Dim tmpFileName As String
    
    Set FSO = CreateObject("scripting.filesystemobject")
    ' 生成唯一临时文件名，避免冲突
    tmpFileName = FSO.GetSpecialFolder(2) & "\" & "tmp_" & Format(Now, "yyyy-mm-dd_hhmmss") & ".mht"
    
    On Error GoTo Cleanup
    ' 保存为MHT，添加错误处理
    objItem.SaveAs tmpFileName, olMHTML
    
    ' 创建Word实例，添加错误处理
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = False
    Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, ReadOnly:=True) ' 只读打开，避免占用
    
    ' 导出为PDF
    wrdDoc.ExportAsFixedFormat _
        OutputFileName:=MyPath, _
        ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, _
        Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, _
        KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, _
        DocStructureTags:=True, _
        BitmapMissingFonts:=True, _
        UseISO19005_1:=False

Cleanup:
    ' 确保Word文档和进程关闭
    If Not wrdDoc Is Nothing Then
        wrdDoc.Close SaveChanges:=False
        Set wrdDoc = Nothing
    End If
    If Not wrdApp Is Nothing Then
        wrdApp.Quit
        Set wrdApp = Nothing
    End If
    ' 删除临时文件
    If FSO.FileExists(tmpFileName) Then
        On Error Resume Next
        FSO.DeleteFile tmpFileName, True ' 强制删除
        On Error GoTo 0
    End If
    ' 清理对象
    Set FSO = Nothing
End Sub

关键修复点说明 #

1. 事件模型优化：将FolderChange改为ItemAdd事件，仅在新邮件移入时触发，避免多次重复处理
2. 临时文件处理：生成唯一临时文件名，执行完成后强制删除，避免文件占用
3. 常量定义：手动定义Word导出所需的常量，解决Late Binding下参数无效问题
4. 错误处理：添加多层错误捕获，确保即使转换失败，资源也能被释放，避免进程残留
5. 路径检查：提前检查PDF保存路径，不存在则自动创建，避免路径错误
6. 只读打开：Word以只读方式打开MHT文件，减少文件占用冲突

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