Auto populate CC field

Question

I am looking for a way that when performing any email action (new email, reply, reply all, forward, etc.) that the CC field gets filled with an email "example@domain.com" before actually sending the email (an Outlook rules adds the CC after sending the email so this does not work)

Reason for adding the CC before the email is sent is so that the user has the ability to remove "examlle@domain.com" if the email is confidential

Any help is greatly appreciated as I have been searching for hours!

LaZoR_Bear · Accepted Answer · 2019-06-11T15:01:28.070

I am unsure of your level of VBA experience but here is a question that was asked on Stack Overflow that contains all the basis of what you want to do.

Add CC

The only things to change would be adding the other actions(currently the code use .forward only): New Email, Reply and Reply All.

Be sure to use .Display and not .Send, so that way the email will be displayed and the sender can then edit what he wants before sending the email.

[EDIT]

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem

'to start the macro when outlook starts  
Private Sub Application_Startup()
   Set oExpl = Application.ActiveExplorer
   bDiscardEvents = False
End Sub

Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.Item(1)
End Sub

'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Reply
 afterReply
End Sub

'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Forward

 afterReply
End Sub

'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.ReplyAll

 afterReply
End Sub

Private Sub afterReply()
    oResponse.Display

 ' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
    oResponse.CC = "example@domain.com"
End Sub

Here is the code I put together and tested in my environnement. Just paste it in your VBA editor under ThisOutlookSession. To lauch it click inside the Application_Startup Sub and hit play. It was heavily inspired by another code I found a while back. I do not have the source however. With this everytime you starup Outlook it should start automatically.

Thank you! So to make sure I have this right as I am brand new to VBA. 1. Open Outlook and press ALT + F11 2. In "ThisOutlookSession" I paste the following code Sub ForwardEmail(item As Outlook.MailItem) Dim oMail As MailItem On Error GoTo Release Set oMail = item.Forward oMail.CC = "example@domain.com" oMail.Display Release: Set oMail = Nothing End Sub 3. Restart Outlook and save the changes when prompted Can't seem to figure out the logic on how to add other actions item.Reply and item.NewEmail — David Ciontea, Jun 11 '19 at 14:34
I added the code I just made that works in my environnement to my original answer. — LaZoR_Bear, Jun 11 '19 at 15:02
I do not know how to make it work on a new mail creation however. — LaZoR_Bear, Jun 11 '19 at 15:11
That worked absolutely perfect!! Is there any way to get it for New Email as well as that is the final requirement from management — David Ciontea, Jun 11 '19 at 15:35
Apologies, I just saw your last comment! Thank you anyways for all your help, it is extremely appreciated!! — David Ciontea, Jun 11 '19 at 15:38

score 1 · Answer 2 · answered Jun 11 '19 at 16:07

@LaZoR_Bear

From some code I found online a while ago to solve this purpose (automatically change the from address on all new emails, replies, reply all, forwards, etc.), I finally figured out the syntax to make it CC on new emails (but your code is still required so thank you again for that).

Code solely to change the from address:

'=================================================================
'Description: Outlook macro to automatically set a different
'             From address.
'
'Comment: You can set the email address at the bottom of the code.
'         Uncomment the myOlExp_InlineResponse sub to also make it
'         work with the Reading Pane reply feature of Outlook 2013/2016/365.
'
' author : Robert Sparnaaij
' version: 1.1
' website: https://www.howto-outlook.com/howto/setfromaddress.htm
'=================================================================

Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer

Private Sub Application_Startup()
    Initialize_handler
End Sub

Public Sub Initialize_handler()
    Set objInspectors = Application.Inspectors
    Set myOlExp = Application.ActiveExplorer
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    If Inspector.CurrentItem.Class = olMail Then
        Set objMailItem = Inspector.CurrentItem
        If objMailItem.Sent = False Then
            Call SetFromAddress(objMailItem)
        End If
    End If
End Sub

'The next 3 lines to enable Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
    Call SetFromAddress(objItem)
End Sub

Public Sub SetFromAddress(oMail As Outlook.MailItem)
    ' Set your preferred default From address below.
    ' Exchange permissions determine if it is actually stamped
    ' as "Sent On Behalf Of" or "Sent As".
    ' The address is not properly updated for the InlineResponse
    ' feature in Outlook 2013/2016/365. This is only a visual bug.
    oMail.SentOnBehalfOfName = "example@doman.com"
End Sub

And then with your code added onto it (plus adding oMail.CC = "example@domain.com" to the code above) looks like this:

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer

Private Sub Application_Startup()
    Initialize_handler
    Set oExpl = Application.ActiveExplorer
    bDiscardEvents = False
End Sub

Public Sub Initialize_handler()
    Set objInspectors = Application.Inspectors
    Set myOlExp = Application.ActiveExplorer
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    If Inspector.CurrentItem.Class = olMail Then
        Set objMailItem = Inspector.CurrentItem
        If objMailItem.Sent = False Then
            Call SetFromAddress(objMailItem)
        End If
    End If
End Sub

'The next 3 lines to enable Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
    Call SetFromAddress(objItem)
End Sub

Public Sub SetFromAddress(oMail As Outlook.MailItem)
    ' Set your preferred default From address below.
    ' Exchange permissions determine if it is actually stamped
    ' as "Sent On Behalf Of" or "Sent As".
    ' The address is not properly updated for the InlineResponse
    ' feature in Outlook 2013/2016/365. This is only a visual bug.
    oMail.SentOnBehalfOfName = "example@domain.com"
    oMail.CC = "example@domain.com"
End Sub

Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.item(1)
End Sub

'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Reply
 afterReply
End Sub

'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Forward

 afterReply
End Sub

'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.ReplyAll

 afterReply
End Sub

Private Sub afterReply()
    oResponse.Display

 ' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
    oResponse.CC = "example@domain.com"
End Sub

Auto populate CC field

2 Answers2