如何修改VBA代码将Outlook邮件另存为docx/PDF并过滤附件

问题分析 #

原代码存在两个核心问题：

1. 直接修改SaveAs的扩展名和格式参数为docx无效，因为Outlook的MailItem.SaveAs不原生支持docx格式，需借助Word转换；PDF可通过指定格式参数直接实现。
2. 附件保存时会包含邮件正文中的内嵌图片，这类附件属于邮件渲染资源而非用户添加的真实附件，需要过滤。

解决方案细节 #

1. 保存邮件为docx或PDF格式 #

• PDF格式：直接使用olPDF作为SaveAs的格式参数，Outlook原生支持该格式导出。
• DOCX格式：通过Outlook邮件的Word编辑器接口，将邮件内容复制到新建Word文档，再保存为docx格式。

2. 仅保存真实附件 #

通过附件的两个属性过滤内嵌资源：

• Position=0：表示该附件是独立添加的，而非内嵌到邮件正文的资源。
• Type <> olEmbeddeditem：排除内嵌对象类型的附件，这类通常是正文里的图片或控件。

修改后的完整代码 #

Public Sub SaveMessagesAndAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strName As String
    Dim strFolderpath As String
    Dim enviro As String
    Dim fso As Object
    ' Word对象变量（用于docx格式转换）
    Dim objWord As Object
    Dim objDoc As Object
    
    enviro = CStr(Environ("USERPROFILE"))
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
    strName = StripIllegalChar(objMsg.Subject)
    
    ' 创建以邮件主题命名的文件夹
    strFolderpath = enviro & "\Documents\" & strName & "\"
    If Not fso.FolderExists(strFolderpath) Then
        fso.CreateFolder (strFolderpath)
    End If
    
    ' 保存为PDF格式（Outlook原生支持）
    objMsg.SaveAs strFolderpath & strName & ".pdf", olPDF
    
    ' 保存为DOCX格式（借助Word转换）
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    ' 复制邮件内容到Word文档
    objMsg.GetInspector.WordEditor.Range.Copy
    objDoc.Range.Paste
    ' 保存为docx格式并关闭文档
    objDoc.SaveAs2 strFolderpath & strName & ".docx", FileFormat:=16 ' 16对应Word的docx格式
    objDoc.Close
    objWord.Quit
    Set objDoc = Nothing
    Set objWord = Nothing
    
    ' 仅保存真实附件（过滤内嵌图片）
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    
    If lngCount > 0 Then
        For i = lngCount To 1 Step -1
            ' 仅保存独立附件，排除内嵌对象
            If objAttachments.Item(i).Position = 0 And objAttachments.Item(i).Type <> olEmbeddeditem Then
                strFile = objAttachments.Item(i).FileName
                strFile = strFolderpath & strFile
                ' 处理重名附件，自动添加序号避免覆盖
                If fso.FileExists(strFile) Then
                    strFile = strFolderpath & fso.GetBaseName(strFile) & "_" & i & "." & fso.GetExtensionName(strFile)
                End If
                objAttachments.Item(i).SaveAsFile strFile
            End If
        Next i
    End If
    
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objOL = Nothing
    Set fso = Nothing
End Sub

Function StripIllegalChar(StrInput)
    Dim RegX As Object
    Set RegX = CreateObject("vbscript.regexp")
    
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    
    StripIllegalChar = RegX.Replace(StrInput, "")
    
ExitFunction:
    Set RegX = Nothing
End Function

代码说明 #

1. PDF导出：使用olPDF常量（对应数值17）作为SaveAs的格式参数，无需额外依赖。
2. DOCX导出：通过GetInspector.WordEditor获取邮件的Word编辑实例，复制内容到新文档后保存为docx，确保格式兼容。
3. 附件过滤：双重判断确保只保留用户主动添加的附件，剔除正文内嵌的图片等资源。
4. 重名处理：自动为重复文件名添加序号，避免文件覆盖。

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