有条件地阻止Outlook根据发件人和收件人地址发送电子邮件
问题描述:
我在Outlook 2007中设置了多个邮件帐户(例如,[email protected],[email protected]等)。有时,通常由于自动完成功能,我会错误地将[email protected]发送的电子邮件发送给收件人,该收件人只能从[email protected]接收邮件)。有条件地阻止Outlook根据发件人和收件人地址发送电子邮件
从(我选择的邮件帐户)和收件人(收件人或抄送)电子邮件地址之间的这些限制通常可以通过域名定义。
例如,[email protected]不应发送给recipient-domainX.com & recipient-domainY.com。 [email protected]不应发送给recipient-domain1.com & recipient-domain2.com。
因此,在VBA脚本或文本文件中明确定义或“硬编码”每个邮件帐户的这些域限制是很好的。
那么,如果使用VBA或其他方式,我可以如何实施电子邮件地址检查,以防止在违反这些限制之一时发送电子邮件。
开放给其他更优雅的解决方案。
谢谢。
答
这可让您通过地址屏蔽电子邮件。我无法对此表示赞赏,主要是将几个不同的代码在线发布合并为一个代码。无论如何,它运作稳定,应该让你一路走到你想要的地方。这用于我们公司将所有外部发送的电子邮件发送到公共文件夹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
答
我修改了代码,稍微容易阅读,实际上相同的代码只是一个小整理。
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