在向多个可能的内部域之外发送消息之前发出警告？

Question

我正在尝试检查我的电子邮件的收件人是否在 Outlook 2016 的全局地址列表中。

如果所有收件人都是内部收件人（我们的 GAL 仅包含内部地址），则邮件会被释放。

如果至少有一个收件人是外部收件人（来自 GAL 外部），那么我应该会收到一条警告消息，询问我是否仍要发送这封电子邮件。

我尝试了 this 主题，但我需要一个无需将地址复制到外部 Excel 电子表格的解决方案。

我也曾使用 this 解决方案，但我们公司很大，在全球设有多个分支机构。引用的解决方案检查我的域是否与收件人域相同。当我试图向我公司的人员发送电子邮件时出现问题，但在我的区域之外 - 我来自 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

Answer 1

您可以用域数组替换单个内部域。

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

在向多个可能的内部域之外发送消息之前发出警告？

Warn before sending messages outside of multiple possible internal domains?

outlook

vba

gal