有条件地阻止 Outlook 根据发件人和收件人地址发送电子邮件

Question

我在 Outlook 2007 中设置了多个邮件帐户（例如 johndoe@domainA.com、johndoe@domainB.com 等）。有时，通常由于自动完成功能，我会错误地将电子邮件从 johndoe@domainA.com 发送给应该只接收来自 johndoe@domainB.com 的邮件的收件人。

发件人（我选择的邮件帐户）和收件人（收件人或抄送）电子邮件地址之间的这些限制通常可以通过域名来定义。

例如，johndoe@domainA.com 不应发送到接收者-domainX.com 和接收者-domainY.com。并且 johndoe@domainB.com 不应发送到接收者域 1.com 和接收者域 2.com。

因此，最好在 VBA 脚本或文本文件中为每个邮件帐户明确定义或“硬编码”这些域限制。

那么，如何使用 VBA 或其他方式检查电子邮件地址，以防止在违反这些限制之一时发送电子邮件。

也欢迎其他更优雅的解决方案。

谢谢。

Answer 1

这使您可以按地址筛选电子邮件。我不能为此声称太多功劳，它主要是在线发布的几个不同的代码合并为一个。无论如何，它工作得很好，应该能让你达到你想去的地方的一半。这在我们公司用于将所有外部发送的电子邮件发送到公共文件夹 HR 评论中。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class <> olMail Then Exit Sub
    Dim objMail As MailItem
    Set objMail = Item
    Dim NotInternal As Boolean
    NotInternal = False
    Dim objRecip As Recipient
    Dim objTo As Object
    Dim str As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next
    Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim i As Integer
    Dim objRecipColl As Recipients
    Set objRecipColl = objMail.Recipients
    Dim objOneRecip As Recipient
    Dim objProp As PropertyAccessor
    For i = 1 To objRecipColl.Count Step 1
        Set objOneRecip = objRecipColl.Item(i)
        Set objProp = objOneRecip.PropertyAccessor
        str = objProp.GetProperty(PidTagSmtpAddress)
        If Len(str) >= 17 Then  'Len of email address screened.  
            If UCase(Right(str, 17)) <> "@COMPANYEMAIL.COM" Then NotInternal = True
        Else
            NotInternal = True
        End If
    Next
    If NotInternal = True Then
        strBcc = "HRExternalEmails@COMPANYEMAIL.com"
        Set objRecip = objMail.Recipients.Add(strBcc)
        objRecip.Type = olBCC
            If Not objRecip.Resolve Then
                strMsg = "Could not resolve the Bcc recipient. " & _
                         "Do you still want 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 objRecipColl = Nothing
    Set objRecip = Nothing
    Set objOneRecip = Nothing
    Set objMail = Nothing
    Set objTo = Nothing
    Set oPA = Nothing
End Sub

Answer 2

我修改了代码，使其更易于阅读，实际上相同的代码更简洁一些。

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

If Item.Class <> olMail Then Exit Sub

Dim sCompanyDomain As String: sCompanyDomain = "companydomain.com"

Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

On Error Resume Next
Dim oMail As MailItem: Set oMail = Item
Dim oRecipients As Recipients: Set oRecipients = oMail.Recipients
Dim bDisplayMsgBox As Boolean: bDisplayMsgBox = False

Dim sExternalAddresses As String
Dim oRecipient As Recipient

For Each oRecipient In oRecipients

    Dim oProperties As PropertyAccessor: Set oProperties = oRecipient.PropertyAccessor
    Dim smtpAddress As String: smtpAddress = oProperties.GetProperty(PidTagSmtpAddress)

    Debug.Print smtpAddress

    If (Len(smtpAddress) >= Len(sCompanyDomain)) Then

        If (Right(LCase(smtpAddress), Len(sCompanyDomain)) <> sCompanyDomain) Then

            ' external address found
            If (sExternalAddresses = "") Then

                sExternalAddresses = smtpAddress

            Else

                sExternalAddresses = sExternalAddresses & ", " & smtpAddress

            End If

            bDisplayMsgBox = True

        End If

    End If

Next

If (bDisplayMsgBox) Then

    Dim iAnswer As Integer
    iAnswer = MsgBox("You are about to send this email externally to " & sExternalAddresses & vbCr & vbCr & "Do you want to continue?", vbExclamation + vbYesNo, "External Email Check")

    If (iAnswer = vbNo) Then
        Cancel = True
    End If

End If

End Sub