Created
May 2, 2019 18:16
-
-
Save hgoldstein95/9aceef21b6ad942e4c64e86aaccbab7d to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment