Outlook365如何转发正文内嵌图片且无附件、不显示原始发件人信息？

问题根因 #

现有代码仅复制了原始邮件的HTML正文内容，没有同步迁移原始邮件中内嵌图片对应的CID附件资源，HTML正文中的cid:资源引用无法在新邮件中匹配到对应文件，因此出现红叉占位。

修复方案1（手动迁移附件，兼容性最高） #

Sub SendTransfer(Item As Outlook.MailItem)
    Dim objMsg As MailItem
    Dim objAttachment As Attachment
    Dim newAttachment As Attachment
    Dim PR_ATTACH_CONTENT_ID As String
    Dim tempPath As String
    
    ' 定义内嵌附件CID对应的MAPI属性标识
    PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
    Set objMsg = Application.CreateItem(olMailItem)
    
    ' 迁移所有内嵌图片附件，保留原始CID对应关系
    For Each objAttachment In Item.Attachments
        ' 仅处理内嵌类型附件，跳过普通外置附件
        If objAttachment.Type = olEmbeddeditem Then
            ' 临时保存原始附件到系统临时目录
            tempPath = Environ("TEMP") & "\" & objAttachment.FileName
            objAttachment.SaveAsFile tempPath
            ' 将附件添加到新邮件
            Set newAttachment = objMsg.Attachments.Add(tempPath, olByValue, , objAttachment.DisplayName)
            ' 同步设置和原始邮件一致的CID，保证HTML引用匹配
            newAttachment.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, _
                objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
            ' 删除临时文件
            Kill tempPath
        End If
    Next
    
    ' 附件迁移完成后再赋值HTML正文
    objMsg.HTMLBody = Item.HTMLBody
    objMsg.Subject = "xxxx2022" & Item.Subject
    objMsg.Recipients.Add "xxxxxx"
    
    objMsg.Send
    
    ' 释放对象资源
    Set objAttachment = Nothing
    Set newAttachment = Nothing
    Set objMsg = Nothing
End Sub

修复方案2（基于转发接口实现，代码更简洁） #

直接调用Outlook原生转发接口创建新邮件，无需手动处理附件迁移，只需清空转发自动生成的发件人头部即可实现隐藏原始发件人的需求：

Sub SendTransfer(Item As Outlook.MailItem)
    Dim objMsg As MailItem
    Set objMsg = Item.Forward
    
    ' 直接覆盖正文，清空转发自动生成的原始发件人、历史回复前缀信息
    objMsg.HTMLBody = Item.HTMLBody
    objMsg.Subject = "xxxx2022" & Item.Subject
    ' 清空转发默认携带的原始收件人信息
    objMsg.Recipients.RemoveAll
    objMsg.Recipients.Add "xxxxxx"
    
    objMsg.Send
    Set objMsg = Nothing
End Sub

注意事项 #

• 两种方案均不会将内嵌图片转为外置附件，收件人看到的效果和原始邮件完全一致
• 如果需要保留原始邮件中的普通外置附件，方案1删除If objAttachment.Type = olEmbeddeditem Then的判断条件即可

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