Outlook VBA实现带附件回复全部，排除正文图片附件

你当前的代码会将邮件正文中的嵌入式图片也当作附件复制到回复里，原因是Outlook把这类图片归类为附件的一种，只是它们被嵌入到邮件内容中而非独立附加。要过滤掉这些图片，我们可以通过附件的属性来区分真正的文件附件和嵌入式图片。

修改后的完整代码 #

Sub ReplyAllWithAttachments()
    Dim oReply As Outlook.MailItem
    Dim oItem As Object
     
    Set oItem = GetCurrentItem()
    If Not oItem Is Nothing Then
        Set oReply = oItem.ReplyAll
        CopyAttachments oItem, oReply
        oReply.Display
        oItem.UnRead = False
    End If
     
    Set oReply = Nothing
    Set oItem = Nothing
End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
         
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
     
    Set objApp = Nothing
End Function

Sub CopyAttachments(objSourceItem, objTargetItem)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
   strPath = fldTemp.Path & "\"
   For Each objAtt In objSourceItem.Attachments
       ' 标记是否为正文嵌入式图片
       Dim isEmbedded As Boolean
       isEmbedded = False
       
       ' 检查HTML正文的嵌入式图片（通过Content-ID属性判断）
       On Error Resume Next
       Dim contentID As String
       contentID = objAtt.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
       If Err.Number = 0 And contentID <> "" Then
           isEmbedded = True
       End If
       On Error GoTo 0
       
       ' 检查RTF正文的嵌入式图片（通过AttachmentType判断）
       If objAtt.AttachmentType = olEmbeddeditem Then
           isEmbedded = True
       End If
       
       ' 仅复制非嵌入式的独立文件附件
       If Not isEmbedded And objAtt.AttachmentType = olByValue Then
           strFile = strPath & objAtt.FileName
           objAtt.SaveAsFile strFile
           objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
           fso.DeleteFile strFile
       End If
   Next

   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

关键修改说明 #

1. 过滤HTML正文图片：通过PropertyAccessor获取附件的Content-ID属性，HTML正文中的图片会带有该属性用于引用（如<img src="cid:xxx">），存在该属性则判定为嵌入式图片，跳过复制。
2. 过滤RTF正文图片：RTF格式邮件中的嵌入式图片AttachmentType属性为olEmbeddeditem，直接标记为嵌入式图片。
3. 仅复制独立文件附件：只保留AttachmentType为olByValue的附件，这类是用户手动添加的独立文件。

如果不想依赖Outlook枚举值，也可以直接用对应数值替换：olEmbeddeditem对应5，olByValue对应1。

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