Automate reply-all (or forward) email and keep original text, then populate with excel data - excel VBA

wiseone

Board Regular
Joined
Mar 14, 2015
Messages
136
Hi All,

Been working on this today and not getting the desired results...so turning to the experts...hoping someone can help. I'm currently stuck trying to get the original message to appear, and the signature added. When I step through, the forward email works and populates with my signature, but then it is getting overwritten by the code below. (Adding my signature is my default outlook setting to replies and forwards.)

I have copied code from a few different sources over the day so I appreciate if you suggest better/cleaner way to do this.

I am trying to automate a reply (or forward) email which I can then populate with data from excel. The work flow would be as such:

1. Open the appropriate email in outlook.
2. Tab over to Excel.
3. Select appropriate row in excel.
4. Click Button.
5. Email is generated with correct data and appears as a normal reply to the email which was opened.
6. I click send.

Here are my requirements for the reply:

1. The email I am replying to will need to have the attachment (if any) included in the reply email. (this is why I started testing with forwarding). I know people will think it is strange to resend the original file, but it is a standard company practice......don't ask.

2. The email I am replying to will need to include all original recipients of the original email, in the correct fields (Same as a reply-all).

3. I need to append the CC and BCC with additional emails.

4. The email will need to keep the original text, similar to a normal reply, with the line that normally separates replies. (I am stumped here at the moment, original text is disappearing with my current code.

5. The Email will need to be HTML formatted due to the information being added.

6. The email signature of whoever uses the excel file should be included.

7. The original subject will get appended.

8. Looking for Excel VBA code, not Outlook VBA code.

Thanks in advance for your help!

VBA Code:
'Base code Source: https://www.extendoffice.com/documents/excel/4656-excel-send-email-based-on-cell-value.html
'And here: https://www.mrexcel.com/board/threads/replying-to-a-selected-email-with-vba.1000382/

'This macro will create a forwarded email based on information in the Excel File

Option Explicit

Sub Confirmation_Email_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim Signature As String
    Dim SenderEmail As String
    Dim OriginalSubject As String
    Dim ForwardEmail As Object

    Const olMail = 43 'Not sure what 43 represents...just got this from code in links above
 
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = Get_Current_Outlook_Item(xOutApp) 'Replies to open email in outlook

'Use this syntax for HTML formatted text:
    xMailBody = "<p style='font-family:calibri;font-size:15'>Hello " & "NAME HERE, ENTER YOUR DATA HERE" & "</p>" & _
                           Signature  'Signature not working
 
    If Not xOutMail Is Nothing Then
            If xOutMail.Class = olMail Then
                SenderEmail = xOutMail.SenderEmailAddress 'Copy original sender
                OriginalSubject = xOutMail.Subject 'Copy Original Subject
             
                Set ForwardEmail = xOutMail.Forward
             
                With ForwardEmail
                    .Display
                    'Signature = xOutMail.HtmlBody 'This isnt working yet'
                    .To = SenderEmail 'Original sender added to forwarded message - Works!
                    .CC = "Enter emails here"
                    .BCC = "Enter emails here"
                    .Subject = "Appended text here" & OriginalSubject 'Subject appended - works!
                    .HtmlBody = xMailBody
                End With
            Else
                MsgBox "The current Outlook item is not an email"
            End If
        Else
            MsgBox "The current Outlook item is not an email"
    End If

    Set xOutMail = Nothing
    Set xOutApp = Nothing
    Set ForwardEmail = Nothing

End Sub



'This function gets the current active item in outlook.
Private Function Get_Current_Outlook_Item(OutlookApp As Object) As Object
     
    On Error Resume Next
 
    Select Case TypeName(OutlookApp.ActiveWindow)
        Case "Explorer"
            Set Get_Current_Outlook_Item = OutlookApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set Get_Current_Outlook_Item = OutlookApp.ActiveInspector.CurrentItem
        Case Else
            Set Get_Current_Outlook_Item = Nothing
    End Select
 
    On Error GoTo 0
 
End Function
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Watch MrExcel Video

Forum statistics

Threads
1,129,593
Messages
5,637,294
Members
416,963
Latest member
zazama

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top