Question

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

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

例如，johndoe @ domainA.com不应发送给recipient-domainX.com＆amp; recipient-domainY.com。并且johndoe@domainB.com不应该发送给recipient-domain1.com＆amp; recipient-domain2.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

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

2 个答案: