vba 有条件地阻止 Outlook 根据发件人和收件人地址发送电子邮件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/5596835/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Conditionally Prevent Outlook from Sending Email Based on From and Recipient Addresses
提问by splounx
I have multiple mail accounts setup in Outlook 2007 (e.g., [email protected], [email protected], etc.). Occasionally, usually as the result of the Auto Complete feature, I will mistakenly send email from [email protected] to a recipient that should only be receiving mail from [email protected]).
我在 Outlook 2007 中设置了多个邮件帐户（例如，[email protected]、[email protected] 等）。有时，通常是自动完成功能的结果，我会错误地将电子邮件从 [email protected] 发送到应该只从 [email protected] 接收邮件的收件人）。
These restrictions between from (my selected mail account) and recipient (To or CC) email addresses can generally be defined by domain name.
发件人（我选择的邮件帐户）和收件人（收件人或抄送）电子邮件地址之间的这些限制通常可以通过域名来定义。
For example, [email protected] should not send to recipient-domainX.com & recipient-domainY.com. And [email protected] should not send to recipient-domain1.com & recipient-domain2.com.
例如，[email protected] 不应发送到收件人域X.com 和收件人域Y.com。并且 [email protected] 不应发送到收件人域 1.com 和收件人域 2.com。
So it would be fine to explicitly define or "hardcode" these domain restrictions per mail account in a VBA script or text file.
因此，最好在 VBA 脚本或文本文件中为每个邮件帐户明确定义或“硬编码”这些域限制。
So how, using VBA or other means, can I implement a check of the email addresses, to prevent an email from being sent if one of these restrictions is being violated.
那么，如何使用 VBA 或其他方式来检查电子邮件地址，以防止在违反这些限制之一的情况下发送电子邮件。
Open to other more elegant solutions as well.
也可以接受其他更优雅的解决方案。
Thanks.
谢谢。
回答by Ken
This lets you screen emails out by address. I can't claim much credit for this, it's largely several different codes posted online merged into one. Regardless, it works solid and should get you half way to where you want to be. This is used in our company to send all externally sent emails into a public folder HR reviews.
这使您可以按地址筛选电子邮件。我不能为此声称太多功劳，它主要是在线发布的几个不同的代码合并为一个。无论如何，它运行良好，应该能让你到达你想去的地方。这用于我们公司将所有外部发送的电子邮件发送到公共文件夹 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
回答by Abu Belal
I've modified the code to be slightly easier to read, effectively the same code just a little neater.
我修改了代码以使其更易于阅读，实际上相同的代码更简洁一些。
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
