vbaemailoutlook

Check strings on Mail.Body or Subject of reply mail and add recipients


When my managers send an email to do some work,
then after I finish that work and press (reply or ReplyAll) and send that email,
I found I forgot to add some recipients (not included on the original mail).

I do not add these recipients to all my email replies, only if the mail.Body or Subject contains specific words. e.g “Test” or “vip”.

I already have added these recipients to a contact group with name e.g “5-Task Team”.

I need VBA to:

1- Check strings on the replied mail (after I click reply/All on the ribbon or choose it from context menu),
2- if it contains specific words, show a Message Box to remind me,
3- then add my contact group to the recipients (To Field)

I will send the mail manually.

The below code works only with showing the message box.
It fails to add the recipients (even if hard-coded), without any error raised.

This sub is found in a separate module:

Option Explicit
Option Compare Text

Sub Check_Body_before_sendReply()
    Dim olMail As Outlook.MailItem
    Set olMail = Application.ActiveExplorer().Selection(1)

    Debug.Print olMail.Body

    If olMail.Body Like "*Test*" Or olMail.Body Like "*VIP*" Then
        MsgBox "Required strings are found"
        olMail.Recipients.Add ("Test@Test.net")  ‘hardcoded because I do not know how to add a contact group
    Else
         MsgBox "Not Found"  'just for testing purpose
    End If
End Sub

This code is in ThisOutlookSession (no other code):

Option Explicit
Option Compare Text

Private WithEvents myAttExp As Explorer
Private WithEvents myAttOriginatorMail As MailItem
Dim WithEvents oMailItem As Outlook.MailItem

Private Sub Application_Startup()
    Set myAttExp = ActiveExplorer
End Sub

Private Sub myAttOriginatorMail_Reply(ByVal Response As Object, Cancel As Boolean)
     Check_Body_before_sendReply
End Sub

Private Sub myAttOriginatorMail_ReplyAll(ByVal Response As Object, Cancel As Boolean)
    Check_Body_before_sendReply
End Sub

Private Sub myAttExp_SelectionChange()
    On Error Resume Next
    If TypeOf myAttExp.Selection.Item(1) Is MailItem Then
        Set myAttOriginatorMail = myAttExp.Selection.Item(1)
    End If
End Sub

Solution

  • Edit Response not ActiveExplorer().Selection(1).

    Private Sub myAttOriginatorMail_Reply(ByVal Response As Object, Cancel As Boolean)
         
         Debug.Print Response.Body
    
        If Response.Body Like "*Test*" Or Response.Body Like "*VIP*" Then
           MsgBox "Required strings are found"
           Response.Recipients.Add ("Test@Test.net")
        Else
           MsgBox "Not Found"  'just for testing purpose
        End If
        
    End Sub