Auto BCC - Multiple Email Addresses

Question

I want to automatically BCC two email addresses.

I found this code from groovypost.com but it can only BCC one address.

Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next

' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "[email protected]"

Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
    strMsg = "Could not resolve the Bcc recipient. " & _
      "Do you want still to send the message?"
    res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
      "Could Not Resolve Bcc Recipient")
    If res = vbNo Then
        Cancel = True
    End If
End If

End If

Set objRecip = Nothing

Answer 1

The below adjustments should allow you to enter as many addresses as you want, provided that you split them with a semicolon ;. It creates an array of addresses and repeats the process for as many email iterations exist.

Side note. I did lookup what I presume is this article you mentioned. I noticed that it made the strong claim that this code would not store the BCC record in the sender's sent box. I don't believe this to be true. Thus I'm not sure what the real advantage is to using this VBA code versus just setting up a message rule.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'make sure to separate with ;
Const strBcc As String = "[email protected];[email protected]"

Dim objRecip As Recipient, strMsg As String, res As Long, i As Long
'On Error Resume Next

Dim theAddresses() As String
    theAddresses = Split(strBcc, ";", -1)

For i = LBound(theAddresses) To UBound(theAddresses)

    Set objRecip = Item.Recipients.Add(theAddresses(i))
    objRecip.Type = olBCC

    If Not objRecip.Resolve Then
        
        strMsg = "Could not resolve the Bcc recipient. " & _
            "Do you want still to send the message?"
    
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
        "Could Not Resolve Bcc Recipient")
            
        If res = vbNo Then
            Cancel = True
            End
        End If
    End If
Next i

Set objRecip = Nothing
End Sub