vbaoutlookreply

Reply with .oft template and show images and attachments

When I create an email from an .oft template it doesn't show all the content of the e-mail.
It's missing content like images and/or attachments.

I tried to merge Sub reply1() and Sub reply2():

Sub Reply1()

Dim Original As Outlook.MailItem
Dim Reply As Outlook.MailItem
Set Original = Application.ActiveExplorer.Selection(1).Reply
Set Reply = Application.CreateItemFromTemplate("C:\Outlook\Mail.oft")

Original.HTMLBody = Reply.HTMLBody & Original.HTMLBody
Original.Display
End Sub

Sub Reply1()
This code doesn't show images or attachments of my own .oft mail.
It does show my e-mail signature but at the very bottom of both mails.
It does show the content of the e-mail I respond to correctly.

Sub Reply2()

Dim origEmail As MailItem
Dim replyEmail As MailItem

Set origEmail = ActiveExplorer.Selection(1)
Set replyEmail = CreateItemFromTemplate("C:\Outlook\Mail.oft")

replyEmail.To = origEmail.Reply.To

replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.Recipients.ResolveAll
replyEmail.Display

Set origEmail = Nothing
Set replyEmail = Nothing

End Sub

Sub Reply2() does the opposite of Sub Reply1.
It shows the images and attachments of my own .oft mail.
It will not show my e-mail signature correctly.
It will not display the content of the mail I respond to correctly. The images are missing

Sub Reply1() Results:
enter image description here

Sub Reply2() Results enter image description here

Solution

  • The code below does work in my situation.

    Sub Reply1()
Dim fromTemplate As MailItem
Dim reply As MailItem
Dim oItem As Object

Set fromTemplate = CreateItemFromTemplate("C:\Outlook\Mail.oft")

Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set reply = oItem.ReplyAll
CopyAttachments oItem, fromTemplate, reply
    
reply.HTMLBody = fromTemplate.HTMLBody & reply.HTMLBody
    
reply.Display
oItem.UnRead = False
End If
 
Set reply = 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(source1, source2, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In source1.Attachments
strFile = strPath & objAtt.fileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

For Each objAtt In source2.Attachments
strFile = strPath & objAtt.fileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing
End Sub