vba - 复制和转发正文中包含图像的电子邮件

Question

我正在尝试复制电子邮件正文并将其放入模板中，然后用户才能转发它。

原始电子邮件正文中的图像变成了内部带有红色 X 的空白框。

错误信息:

The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location.

我需要将原始图像复制到一个临时文件夹中，然后将它们重新插入到我的电子邮件中。

我的宏可以将图像复制到临时文件夹中。我如何将这些图像放入最终的电子邮件中？

更新:
我想出了如何将我的临时文件中的图像作为隐藏附件添加到我的电子邮件中。 (我在下面更新了我的代码)。我认为问题在于 HTML 图像标签仍在引用我旧电子邮件中图像的位置(例如:src="cid:image001.jpg@01D09693.82092260")。

删除“@01D09693.82092260”是否会使标签从当前附件中获取图像？我该怎么做？

Sub ForwardEmail()

    Dim Item As Outlook.MailItem
    Dim oForward As Outlook.MailItem
    Dim olAttach As Outlook.Attachments
    Dim strFileN As String

    Set Item = GetCurrentItem
    Set oForward = Application.CreateItemFromTemplate("Z:\Template.oft")

    strFileN = Dir("K:\Temp\*.*")

    With oForward
        .Subject = Item.Subject
        .HTMLBody = Item.HTMLBody & oForward.HTMLBody

        Do While Len(strFileN) > 0
            .Attachments.Add "K:\Temp\" & strFileN, olByValue, 0
            strFileN = Dir
        Loop

        .Display
        .BodyFormat = olFormatHTML
    End With
    
    Kill "K:\Temp\*.*"
        
    Set Item = Nothing
    Set oForward = Nothing

End Sub
    
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
                
    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
        
    strFolderpath = "K:\Temp\"
     
    Set objAttachments = GetCurrentItem.Attachments
    lngCount = objAttachments.Count
             
    If lngCount > 0 Then
       
    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.
         
        For i = lngCount To 1 Step -1
         
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName
         
            ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile
         
            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
         
        Next i
    End If
            
    Set objApp = Nothing
    Set objAttachments = Nothing
    Set objSelection = Nothing
    
End Function

Answer 1

Add Attachments 类的方法允许将文件附加到邮件。

您还需要使用 Attachment.PropertyAccessor 在附件上设置 PR_ATTACH_CONTENT_ID 属性 (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F)。请注意，附件类的 PropertyAccessor 属性是在 Outlook 2007 中添加的。

您可能会找到 How do I embed image in Outlook Message in VBA?链接有帮助。

参见 vba email embed image not showing获取完整的示例代码。