Outlook 2010 自动密件抄送，但有例外

Question

我继承了一个办公网络。 我的目标是将mydomain.com 的所有（传入和传出）电子邮件发送到外部地址some_email@external_domain.com

场景： mydomain.com 的邮件服务器托管在外部（无交换服务器）。客户使用 Outlook 2010 进行 POP 和发送电子邮件。

-每个电子邮件地址在服务器端都有一个转发到some_email@external_domain.com

-每个 Outlook 2010 客户端都已配置：

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 = "some_email@external_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 to send the message?"
    res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
            "Could Not Resolve Bcc")
    If res = vbNo Then
        Cancel = True
    End If
End If

现在一切正常....除了用户从mydomain.com 向mydomain.com 发送电子邮件时。当然，some_email@external_domain.com 会收到两封电子邮件（来自自动密件抄送和一个服务器端转发）

我的问题：是否可以从自动密件抄送中排除 *@mydomain.com？

Answer 1

经过反复试验，我通过以下方式实现了这一目标：

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

If Item.To Like "*@mydomain.com" Or Item.CC Like "*@mydomain.com" Then
'Do nothing
Else
    strBcc = "some_email@external_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

Set objRecip = Nothing

End Sub

这将自动密件抄送所有电子邮件，除非“收件人”或“抄送”包含“@mydomain.com”。到目前为止，我的测试工作正常。

这是我第一次修补 VBA，希望看到任何 cmets/建议。