Copy and Forward Email With Images in Body

Question

I'm trying to copy the body of an email and put it into a template before the user can forward it.

Images in the body of the original email become blank boxes with red Xs inside of them.

Error message:

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.

I need to copy the original images into a temp folder then reinsert them into my email.

My macro can copy the images into a temp folder. How do I put these images into the final email?

UPDATE:
I figured out how to add the images in my temp file to my email as hidden attachment. (I updated my code below). I think the problem is that the HTML image tags are still referencing the location of the images in my old email (ex: src="cid:image001.jpg@01D09693.82092260").

Will removing the "@01D09693.82092260" make the tag get the image from the current attachments? How do I do that?

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

The Add method of the Attachments class allows to attach files to the mail.

Also you need to set PR_ATTACH_CONTENT_ID property (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F ) on the attachment using Attachment.PropertyAccessor. Be aware, the PropertyAccessor property of the Attachment class was added in Outlook 2007.

You may find the How do I embed image in Outlook Message in VBA? link helpful.

See vba email embed image not showing for the complete sample code.

Answer 2

I solved it myself!

I resorted to using RegEx to remove the offending Hex path in order to get the images to link to the currently attached ones. This took a quite some time with getting my regular expressions to work properly but here's the final code!

Sub ForwardEmail()

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

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

sBadHex = GetBadHex(Item.HTMLBody)
sEmailHTML = Replace(Item.HTMLBody, sBadHex, "")

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

    With oForward
        .Subject = Item.Subject
        .HTMLBody = sEmailHTML & oForward.HTMLBody
        Do While Len(strFileN) > 0
            .Attachments.Add "K:\Temp\" & strFileN, olByValue, 0
            strFileN = Dir
        Loop
        '.BodyFormat = olFormatHTML <-- I don't think you need this
        .Display
    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

Function GetBadHex(sInput As String) As String
 Dim rImgTag As RegExp
 Set rImgTag = New RegExp
 Dim mImgTag As Object
 Dim rBadHex As RegExp
 Set rBadHex = New RegExp
 Dim mBadHex As Object


 Dim sImgTag As String
 Dim sBadHex As String

     With rImgTag
        .Pattern = "cid:image[0-9]{3}\.[a-z]{3}@[0-9A-Z]{8}\.[0-9A-Z]{8}"
     End With

     With rBadHex
        .Pattern = "@[0-9A-Z]{8}\.[0-9A-Z]{8}"
     End With

Set mImgTag = rImgTag.Execute(sInput)

If mImgTag.Count <> 0 Then
    sImgTag = mImgTag.Item(0)
End If


Set mBadHex = rBadHex.Execute(sImgTag)

If mBadHex.Count <> 0 Then
    sBadHex = mBadHex.Item(0)
End If

GetBadHex = sBadHex
Set rImgTag = Nothing
Set rBadHex = Nothing

End Function