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

Question

我在 Outlook 2007 中设置了多个邮件帐户（例如，[电子邮件受保护] 、[电子邮件受保护]等）。有时，通常是由于自动完成功能的原因，我会错误地从 [email  protected] 发送至仅应接收来自 [电子邮件受保护] 的邮件的收件人）。

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

例如，[电子邮件受保护] 不应发送到recipient-domainX.com &收件人域Y.com。并且 [email protected] 不应发送到recipient-domain1.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 = "[email protected]"
        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