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

Question

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

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

例如，johndoe@domainA.com不应发送给recipient-domainX.com & recipient-domainY.com。 johndoe@domainB.com不应发送给recipient-domain1.com & 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