EmailDomainMatch.vba

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    On Error Resume Next
    Dim recip As Outlook.Recipient
    Dim ToAddress As String
    Dim FromAddress As String
    Dim pa As Outlook.PropertyAccessor
    Dim shouldPrompt As Boolean
    Dim Whitelist
    
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    
    Whitelist = Array("hgoldstein95@gmail.com")
    shouldPrompt = False
    FromAddress = LCase(Item.SendUsingAccount.SmtpAddress)
    For Each recip In Item.Recipients
        Set pa = recip.PropertyAccessor
        ToAddress = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
        
        If GetDomain(FromAddress) <> GetDomain(ToAddress) And Not (IsInArray(ToAddress, Whitelist)) Then
            shouldPrompt = True
        End If
    Next
    
    If shouldPrompt Then
        Prompt$ = "You are sending to a recipient on a different domain. Are you sure you're sending from the right address?"
        If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
    End If
End Sub

Function GetDomain(emailAddress As String) As String
    Dim arr As Variant
    arr = Split(emailAddress, "@")
    GetDomain = arr(1)
End Function

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False
End Function