Outlook 2007 中的 ItemSend 事件中的密件抄送不再有效

Question

I inserted code in ItemSend and saved the ThisOutlookSession module. It worked once and no longer works. It was saved as VBAproject.OTM and is still there when I open the module 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 = "someone@somewhere.dom"

    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

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 = "someone@somewhere.dom"

    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

Answer 2

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 3

I was having this issue recently. It started after the .pst file was corrupted in some way and I had to run scanpst.exe (which I had to search my drive for because the error message does not tell you where it is)

After running scanpst.exe and the issue presented itself, this is how I fixed it.

First, I fiddled with macro security. I set it to the lowest setting. Here is a link that covers how to change macro security . Go to Tools > Macro > Security. I set it to "No security check for Macros."

Then I used this exact code:

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 = "PUT YOUR EMAIL ADDRESS HERE AND LEAVE THE QUOTES"

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

Then I clicked the save button then little green play button to run the macro. It asked me for a Macro name. I used bccUsername and clicked create. The editor added a section called Modules under ThisOutLookSession .

I then restarted Outlook and tested twice and it worked.

I'm not exactly sure what I did that made it start working again, but this is not too involved with the steps so hopefully this helps you and others with the same problem.