Outlook VBA macro to compose and forward email with pictures in body
I am a complete VBA noob and I am trying to create an Outlook macro that will copy the body of an email and place it in a template before the user can forward it.
My problem is that in the email that the macro creates, the images in the body of the original email become an empty box with red Xs inside them (error message: The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Make sure the link points to the correct file and location.).
I figured out that I need to copy the original images to a temporary folder and then paste them into my email. The following code is what my macro looks like so far, it can copy images to a temporary folder, but I don't know how to put these images in the final email. If someone can provide some sample code on how to find and replace the broken image links in the last email with the ones in the temp folder, that would help me a lot. Thank.
UPDATE: I've figured out how to add images in my temp file to my email as hidden attachments (I've updated my code below). I think the problem is that HTML image tags still reference the location of the images in my old email (ex: src = "cid: image001.jpg@01D09693.82092260 "). Will "@ 01D09693.82092260" be removed so that the tag will get the image from the current attachments? How to do it?
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
source to share
I solved it myself!
I have resorted to using RegEx to remove the offending Hex path to get the images to snap to the currently attached ones. It took quite a while for my regex to work correctly, 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
source to share
Add class method Attachments allows you to attach files to mail.
Also you need to set the PR_ATTACH_CONTENT_ID (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F ) property in your application using Attachment.PropertyAccessor. Remember that the PropertyAccessor property of the Attachment class was added in Outlook 2007.
You can find How do I insert a picture in an Outlook message in VBA? useful.
See vba email embed image not showing for full example code.
source to share