展望2010年 - VBA - 集BCC在ItemSend

Question

Program: Outlook 2010
OS: Win8
VBA Skill: Novice

Notes:
This works perfectly if I remove the following option

Private Sub Application Item_Send  
'[3]
If Item.SendUsingAccount = "Account Name here" Then  

If I do not remove it (keeping my BCC exception) the email on startup Private Sub Application _Startup runs however it BCCs only the email listed in item [3] = "special@domain.com".

When part [3] is removed both run as coded.
1) 1 email on startup, BCCing all accounts listed to check the Macro,
2) During the day all emails sent have the correct BCC attached, all the exceptions work as coded.

It seems that there is something that I have missed which stops every mail code from running in to the startup mail code.

I have tried a number of changes, including added IF & else functions.

Both are run in my This Outlook Session

Code:

Private Sub Application_Startup()
'Creates a new e-mail item and modifies its properties on startup
'Testing email settings, checking Macros enabled

Dim olApp As Outlook.Application
Dim objMail As Outlook.mailItem
Set olApp = Outlook.Application

'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)

With objMail
    .Subject = "Login Test" & " | " & Format(Now, "YYYYMMDD - HH:mm:ss")
    .Body = "Testing the BCC" & " | " & Format(Now, "YYYYMMDD")
    .To = "1.alerts@domain.com; device@domain.com"
    .Recipients.ResolveAll
    .Send
End With
End Sub

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'source:    http://www.outlookcode.com/article.aspx?id=72
    'source:    http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/  (exceptions)  [2]
    'source:    http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]


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

    '[2]
    If Item.Categories = "zBCC no" Then
        Exit Sub
    Else
        If Item.To = "personal@domain.com" Then
            Exit Sub
        Else
            If InStr(1, Item.Body, "zebra") Then
                Exit Sub
            Else
                If Item.To = "1@domain.com" Or Item.To = "2@domain.com" Then
                    strBcc = "3@domain.com"
                    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
                    Exit Sub
                Else
                    '[3]
                    If Item.SendUsingAccount = "Account Name here" Then
                        strBcc = "special@domain.com"
                        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
                        Exit Sub
                    Else
                        ' #### USER OPTIONS ####
                        ' address for Bcc -- must be SMTP address or resolvable to a name in the address book
                        strBcc = "1@domain.com"
                        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

                        strBcc = "2@domain.com"
                        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

                        strBcc = "3@domain.com"
                        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
                End If
            End If
        End If
    End If

    Set objRecip = Nothing
End Sub

Answer 1

My possibly false impression is, at the time you wrote this, you did not know how to debug. This may have been helpful http://www.cpearson.com/Excel/DebuggingVBA.aspx

Here is a simplified untested version. I removed all the Else statements.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'source:    http://www.outlookcode.com/article.aspx?id=72
    'source:    http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/  (exceptions)  [2]
    'source:    http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]


    Dim objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String

    '[2]
    If Item.Categories = "zBCC no" Then Exit Sub
    If Item.To = "personal@domain.com" Then Exit Sub
    If InStr(1, Item.Body, "zebra") Then Exit Sub

    If Item.To = "1@domain.com" Or Item.To = "2@domain.com" Then

        strBcc = "3@domain.com"
        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

        GoTo ExitRoutine

    End If

    '[3]
    If Item.SendUsingAccount = "Account Name here" Then

        strBcc = "special@domain.com"
        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

        GoTo ExitRoutine

    End If


    ' #### USER OPTIONS ####
    ' address for Bcc -- must be SMTP address or resolvable to a name in the address book

    strBcc = "1@domain.com"
    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
            GoTo ExitRoutine
        End If
    End If

    strBcc = "2@domain.com"
    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
            GoTo ExitRoutine
        End If
    End If

    strBcc = "3@domain.com"
    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

ExitRoutine:
    Set objRecip = Nothing

End Sub

When you debug you will note Item.SendUsingAccount is always blank.

You can try setting SendUsingAccount Use the mail account you want in your mail macro but it is a little trickier than SentOnBehalfOfName (From). Note manually setting From will not update SentOnBehalfOfName.

You can see how it works with this.

Sub SetSentOnBehalf()

Dim objMsg As MailItem

Set objMsg = Application.CreateItem(0)

objMsg.SentOnBehalfOfName = "bingo@bongo.com"

objMsg.Display

MsgBox " SentOnBehalfOfName in the From: " & objMsg.SentOnBehalfOfName

Set objMsg = Nothing

End Sub