Outlook VBA to BCC emails sent not working in Outlook 2007

Question

Inserted code in ItemSend and saved the ThisOutlookSession module. It worked once and no longer works. Before anyone asks; it was saved as BVaproject.OTM and is still there when I open the module back up after restarting Outlook.

Private Sub Application_ItemSend(ByVal Item As Object, _ Cancel As Boolean) 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

Set objRecip = Nothing

End Sub

Answer 1

If you're hooking the ItemSend event, that should be in a class module with WithEvents and your code to call it in a regular module. Also, you'll want to do an Item.Save on the message for the BCC to stick.

Answer 2

use and if statement on the Item's Subject field

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

If Item.Subject = "exact match" Then

    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
    Item.Save

    Set objRecip = Nothing


End If

or use if you want a contains a word in the subject

If InStr(Item.Subject, "BCCSubject") = 0 Then

End If