Outlook VBA保存邮件附件时误存内嵌图片的解决方案问询

Outlook的Attachments集合不会自动区分用户主动添加的正式附件和邮件正文内嵌资源（包括正文插图、签名带的图片、内嵌样式资源等），当前代码未做附件类型过滤，遍历集合时会把所有类型的关联文件全部保存。

遍历单个附件时增加两层过滤，即可跳过内嵌资源：

• 第一层：仅保留附件类型为olByValue（数值为1，即用户手动添加的常规文件附件）的项
• 第二层：校验附件的内容ID（ContentID），如果该ID被邮件HTML正文以cid:格式引用，说明是正文中的内嵌资源，直接跳过

' 声明用到的常量，兼容不同版本Outlook的引用场景
Const olByValue As Long = 1
Dim Attachments As Outlook.Attachments
Dim AttachmentsCount As Integer
Dim Email As Outlook.MailItem
Dim FolderObj As Object
Dim FolderPath As String
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Selection As Outlook.Selection
Dim att As Outlook.Attachment
Dim isEmbedded As Boolean
     
FolderPath = "C:\XXX\Desktop\TestAttachment"
  
Set FolderObj = CreateObject("Scripting.FileSystemObject")
If Not FolderObj.FolderExists(FolderPath) Then
    FolderObj.CreateFolder FolderPath
End If
   
Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection 
  
AttachmentsCount = 0
  
For Each Email In Selection
    Set Attachments = Email.Attachments
    ' 倒序遍历避免集合索引错乱
    For i = Attachments.Count To 1 Step -1
        Set att = Attachments.Item(i)
        isEmbedded = False
        
        ' 第一层过滤：非普通值类型附件直接跳过
        If att.Type <> olByValue Then
            GoTo NextAttachment
        End If
        
        ' 第二层过滤：判断是否为正文中引用的内嵌资源
        If att.ContentID <> "" Then
            If InStr(1, Email.HTMLBody, "cid:" & att.ContentID, vbTextCompare) > 0 Then
                isEmbedded = True
            End If
        End If
        
        ' 非内嵌资源才执行保存
        If Not isEmbedded Then
            att.SaveAsFile FolderPath & "\" & Format(Email.ReceivedTime, "DD.MM.YYYY hhmm") & "_" & att.FileName
            AttachmentsCount = AttachmentsCount + 1
        End If
        
NextAttachment:
    Next i
Next
  
If AttachmentsCount > 0 Then
    MsgBox "Email Attachment(s) have been saved."
Else
    MsgBox "No Attachment were found to save."
End If

• 保留了倒序遍历附件集合的逻辑，避免跳过项时集合索引偏移导致漏判
• 两层判断可以覆盖绝大多数场景：不会误存正文插图、签名图片、内嵌表情等非用户主动添加的附件，也不会漏掉用户手动上传的常规附件（包括压缩包、文档、可执行文件等所有格式的正式附件）
• 如果遇到特殊格式邮件（比如部分加密邮件、RTF格式邮件）出现漏判，可以额外增加一层判断：当附件的DisplayName和FileName不一致时做二次校验即可。

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