'This Sub display warning message when To and From addesses are different domains
'Save this macro in outlook VB ThisOutlookSession

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
       
  'Find the Sender Domain
  MyDom = ""
  
  'Update this part accoring to your email account
  If InStr(Item.SenderEmailAddress, "google") Then
    MyDom = "google.com"
  ElseIf InStr(Item.SenderEmailAddress, "yahoo") Then
    MyDom = "yahoo.com"
  ElseIf InStr(Item.SenderEmailAddress, "emailid") Then
    MyDom = "outlook.com"  
  End If
  
  'MsgBox ("Sender Domain is " & Item.SenderEmailAddress & " MyDom=" & MyDom)
  
  ' Recip Section  *****************************
  Dim recips As Outlook.Recipients
  Dim recip As Outlook.Recipient
  Set recips = Item.Recipients
  
  Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
  For Each recip In recips
    Set pa = recip.propertyAccessor
    'MsgBox (recip.Name & " Email=" & pa.GetProperty(PR_SMTP_ADDRESS))
    Dim ToArray() As String
    'ToArray() = Split(recip.Address, "@")
    ToArray() = Split(pa.GetProperty(PR_SMTP_ADDRESS), "@")
    ToDom = ToArray(1)
    'ToDom = "Hello"
    If MyDom <> LCase(ToDom) Then
        If MsgBox("---   ALERT ALERT ALERT ALERT ALERT   ---" & vbCrLf _
                  & "Sender Email is    : " & Item.SenderEmailAddress & vbCrLf _
                  & "Recipient Email is : " & pa.GetProperty(PR_SMTP_ADDRESS) & vbCrLf _
                  & "IS THAT OK?", _
                   vbYesNo + vbQuestion + vbMsgBoxSetForeground, "ALERT: Check Address") = vbNo Then
             Cancel = True
        End If
    End If
  Next
  
End Sub