Automatically BCC/CC Send

[podious]

Hello all,

I am looking a VBA code that puts my colleagues into BCC when I use a specific email domain address.

For example;

23604

And example code which is works but not on the way that I want;
23605

**original website (https://www.slipstick.com/outlook/email/automatically-bcc-all-message/)

So can you please help me to make some adjustments to optimize the code,

Best Regards,

Podious

[gmayor]

You just have to check the domain and add the recipients e.g.


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim Res As Integer
Dim strAccount As String
Dim strMessage As String
Const strDomain As String = "yourdomain.com"
Const strBCC1 As String = "emailaddress1"
Const strBCC2 As String = "emailaddress2"
strAccount = Split(Item.SendUsingAccount.DisplayName, "@")(1)
If strAccount = strDomain Then
Set objRecip = Item.Recipients.Add(strBCC1)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
Res = MsgBox("Could not resolve the BCC Recipient " & strBCC1 & vbCr & "Do you want to send the message", vbYesNo)
If Res = vbNo Then Cancel = True
Set objRecip = Nothing
End If
Set objRecip = Item.Recipients.Add(strBCC2)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
Res = MsgBox("Could not resolve the BCC Recipient " & strBCC2 & vbCr & "Do you want to send the message", vbYesNo)
If Res = vbNo Then Cancel = True
Set objRecip = Nothing
End If
End If
Set objRecip = Nothing
End Sub