Warn before sending messages outside of multiple possible internal domains? - vba

Question

I'm trying to check if recipients of my e-mail are in our Global Address List in Outlook 2016.
If all the recipients are internal (our GAL includes only internal addresses) then the message is released.
If at least one of the recipients are external (from outside of GAL), then I should get a warning message, which will ask if I still want to send this e-mail.
I tried this topic, but I need a solution without copying the addresses to external Excel spreadsheet.
I also worked with this solution, but our company is big, and has multiple branches all around the globe. The cited solution checks if my domain is the same with the recipients domains. The problem occurs when I'm trying to send an e-mail to people from my company, but outside my region - I'm from EMEA, and e.g. I'm sending an e-mail to PAM. Unfortunately, this solution is not enough in this moment. Because PAM is using a different domain - the warning message occurs.
The simplest way for me, would be to check the recipients in GAL, but I'm not sure if this is even possible.
Code from the second solution below:
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

You could replace the single internal domain with an array of domains.
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