vba - 在向多个可能的内部域之外发送消息之前发出警告?
问题描述
我正在尝试检查我的电子邮件收件人是否在 Outlook 2016 的全局地址列表中。
如果所有收件人都是内部的(我们的 GAL 仅包括内部地址),则消息将被释放。
如果至少有一个收件人是外部的(来自 GAL 之外),那么我应该收到一条警告消息,询问我是否仍要发送此电子邮件。
我尝试了这个主题,但我需要一个解决方案,而无需将地址复制到外部 Excel 电子表格。
我也使用过这个解决方案,但我们公司很大,在全球有多个分支机构。引用的解决方案检查我的域是否与收件人域相同。当我试图向来自我公司但在我所在地区之外的人发送电子邮件时会出现问题 - 我来自 EMEA,例如我正在向 PAM 发送电子邮件。不幸的是,这个解决方案目前还不够。因为 PAM 使用不同的域 - 出现警告消息。
对我来说最简单的方法是检查 GAL 中的收件人,但我不确定这是否可能。
下面第二个解决方案的代码:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen
Dim strMyDomain
Dim internal As Long
Dim external As Long
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress, "@")
strMyDomain = Right(userAddress, lLen)
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "@")
str1 = Right(Address, lLen)
If str1 = strMyDomain Then internal = 1
If str1 <> strMyDomain Then external = 1
Next
If internal + external = 2 Then
prompt = "This email is being sent to Internal and External addresses. Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End Sub
解决方案
您可以将单个内部域替换为域数组。
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Recipients
Dim recip As Recipient
Dim pa As propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen As Long
Dim Str1 As String
Dim arrayDomains() As Variant
Dim i As Long
Dim internalFlag As Boolean
Dim externalFlag As Boolean
Dim strExtAdd As String
arrayDomains = Array("PAM domain", "EMEA domain", "other internal domain")
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "@")
Str1 = Right(Address, lLen)
internalFlag = False
For i = LBound(arrayDomains) To UBound(arrayDomains)
If Str1 = arrayDomains(i) Then
internalFlag = True
Exit For
End If
Next
If internalFlag = False Then
externalFlag = True
strExtAdd = strExtAdd & vbCr & Address
End If
Next
If externalFlag = True Then
prompt = "This email is being sent to external addresses. Do you still wish to send?" & strExtAdd
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
'Else
'Debug.Print "Internal addresses only."
End If
End Sub
推荐阅读
- php - 使用 PHP 类/函数将 NULL 插入到 mySQL-DB 而不是 0000-00-00
- amazon-web-services - 加密现有 AWS Neptune 数据库实例
- python - 带有“大型”数据库(< 1M 行)的非常慢的 django
- vbscript - 将剪贴板文本放入 VBS 脚本?
- scala - 线程“主”org.apache.spark.SparkException 中的异常:当我将代码移动到类时,任务不可序列化
- sql - 表层次结构概念
- r - 如何以粗体和斜体标记热图的某些行名
- excel - 交叉引用来自同一 Excel 文件的 2 个工作表
- android - 当设备区域设置 strings.xml 不存在时获取备用区域设置
- ruby - Ruby Sinatra URL 不断追加