Outlook Reply with Email Template | VBA Macro #32

'Leverage & Lean "Less Clicks, More Results"
Sub ReplywithEmailTemplate()
' Means variable is in use
Dim Counter As Integer '
Dim CurrentBody As String '
Dim DisplayFiles As String '
Dim EmailCurrent As Outlook.MailItem '
Dim EmailTemplate As Outlook.MailItem '
Dim FolderPath As String '
Dim FolderTemp As Object '
Dim objAtt As Object '
Dim objFSO As Object '
Dim oFile As Object '
Dim oFolder As Object '
Dim oFSO As Object '
Dim strPath As String '
Dim strFile As String '
Dim TemplateName As String '
Dim TemplateNumber As String '
Dim User As String '

On Error GoTo LeverageLean

On Error Resume Next
Set EmailCurrent = Application.ActiveInspector.CurrentItem 'Select the Current Open Email
On Error GoTo 0

If EmailCurrent Is Nothing Then
Set EmailCurrent = Application.ActiveExplorer.Selection.Item(1) 'Select the Current Unopen Email
'Set EmailCurrent = EmailCurrent.Reply 'If you want to Reply with an Email Template
Set EmailCurrent = EmailCurrent.ReplyAll 'If you want to ReplyAll with an Email Template
End If

CurrentBody = EmailCurrent.HTMLBody 'The Active Email's Body

User = (Environ$("Username"))
FolderPath = "C:\Users\" & User & "\AppData\Roaming\Microsoft\Templates\" 'Default Outlook Email Template path. You can update the FolderPath to somewhere else.
 
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(FolderPath)
 
Counter = 1
  
For Each oFile In oFolder.Files 'Loop through every File in FolderPath
If oFile.Type = "Outlook Item Template" Then 'If the File is an .oft add to DisplayFiles
DisplayFiles = DisplayFiles & vbNewLine & Counter & ". " & Left(oFile.Name, Len(oFile.Name) - 4)
Counter = Counter + 1
End If
Next oFile
 
If Len(DisplayFiles) > 1023 Then 'If DisplayFiles exceeds the character limit display MsgBox
MsgBox ("You have exceeded the character limit of the InputBox. " & _
"Email templates that should be available for selection will not be able to display. " & _
"Try making the file names of your email templates shorter. " & _
"Navigate to your folder path here: " & FolderPath)
End If
 
TemplateNumber = InputBox(DisplayFiles, "Reply with Outlook Email Templates") 'Determine what Email Template to Reply with
If TemplateNumber = "" Then Exit Sub

Counter = 1
 
For Each oFile In oFolder.Files 'Loop through every File in FolderPath
If oFile.Type = "Outlook Item Template" Then 'If the File is an .oft
If Counter = TemplateNumber Then 'If the Counter is the same as the selected Template
TemplateName = oFile.Name 'Selected Email Template File Name
End If
Counter = Counter + 1
End If
Next oFile

Set EmailTemplate = Application.CreateItemFromTemplate(FolderPath & "\" & TemplateName) 'The Email Template selected
If EmailTemplate.Attachments.Count > 0 Then 'If the Email Template has Attachments
Const olByValue = 1
Const olEmbeddeditem = 5
Const TemporaryFolder = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set FolderTemp = objFSO.GetSpecialFolder(TemporaryFolder)
strPath = FolderTemp.Path & "\"
For Each objAtt In EmailTemplate.Attachments 'For each Email Template Attachment add to Current Email
Select Case objAtt.Type
Case olByValue, olEmbeddeditem
strFile = strPath & objAtt.Filename
objAtt.SaveAsFile strFile 'Save the Attachment to the Temporary Folder
End Select
If InStr(1, EmailTemplate.HTMLBody, "cid:image") > 0 And InStr(1, EmailTemplate.HTMLBody, ".png") > 0 And InStr(1, objAtt.Filename, ".jpg") = 0 Then
EmailCurrent.Attachments.Add strFile, olByValue 'If there are embedded png images in the selected Email Template exclude jpg attachments
ElseIf InStr(1, EmailTemplate.HTMLBody, "cid:image") = 0 And InStr(1, EmailTemplate.HTMLBody, ".png") = 0 Then
EmailCurrent.Attachments.Add strFile, olByValue 'If no embedded png images in the selected Email Template attach everything
End If
objFSO.DeleteFile strFile 'Delete the Attachment in the Temporary Folder
Next
End If
'EmailCurrent.Subject = EmailTemplate.Subject 'Set Active Email's Subject
EmailCurrent.HTMLBody = EmailTemplate.HTMLBody & CurrentBody 'Set Active Email's Body
EmailCurrent.Display
'EmailCurrent.Send

Set EmailCurrent = Nothing
Set EmailTemplate = Nothing
Set FolderTemp = Nothing
Set objAtt = Nothing
Set objFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing

Exit Sub
 
LeverageLean:
If Err.Number = 76 Then
EmailCurrent.Display
MsgBox ("Something went wrong. Ensure the Folder Path is correct. " & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
ElseIf TemplateNumber = 0 Or TemplateNumber > Counter - 1 Then
EmailCurrent.Display
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
Exit Sub
End If
 
End Sub
'Stay Awesome