Auto populate CC field - vba

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!

Answer 1

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.

Answer 2

#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