Outlook VBA Spoof check - checks sender email against originator email - RED banner if fail

Attribute VB_Name = "otl_SpoofCheck" Option Explicit Option Compare Text ' References: ' - Microsoft Outlook XX.X Object Library ' - Microsoft VBScript Regular Expressions 5.5 ' - Microsoft Scripting Runtime Private Const WARNING_MARKER As String = "<!--CC-HEADER-SPOOF-BANNER-->" Private Const LOG_FILE As String = "C:\temp\AntiSpoof_HeaderOnly_Log.csv" Public Sub Run_HeaderSpoof_OnActive() Dim insp As Outlook.Inspector ' Active mail inspector On Error GoTo Quit Set insp = Application.ActiveInspector If insp Is Nothing Then MsgBox "Open an email first.", vbExclamation Exit Sub End If If TypeName(insp.CurrentItem) = "MailItem" Then Call IsSpoofHeader(insp.CurrentItem) 'MsgBox "Header spoof check complete.", vbInformation Else MsgBox "Active item is not a mail item.", vbExclamation End If Quit: End Sub Public Function IsSpoofHeader(ByVal mi As Outlook.mailItem) As Boolean On Error GoTo FailSafe If mi Is Nothing Then Exit Function Dim actualAddr As String ' SMTP address of sender Dim actualDom As String ' Domain of actual sender Dim hdr As String ' Raw header string Dim reFrom As RegExp ' RegExp to extract From header Dim shownDom As String ' Domain shown in header Dim originDom As String ' Originator domain (Return-Path or Received) Dim matches As MatchCollection ' RegExp match results Dim mismatch As Boolean ' Whether domains mismatch Dim bannerText As String ' Text for warning banner Dim bannerHtml As String ' HTML content for warning banner Dim passList As Variant ' Array of allowed domains or relays Dim passItem As Variant ' For each item in allowlist IsSpoofHeader = False ' Default return is False (not spoofed) actualAddr = GetSenderSmtpAddress(mi) ' Get actual SMTP sender address If Len(actualAddr) = 0 Then Exit Function ' Exit if no address found actualDom = LCase$(GetDomainFromEmail(actualAddr)) ' Extract and lowercase domain hdr = GetHeaderRaw(mi) ' Get full message header If Len(hdr) = 0 Then Exit Function ' Exit if no header present '--- Bypass spoof detection if email passed authentication (e.g., SPF, DMARC) or marked internal ''If InStr(1, hdr, "spf=pass", vbTextCompare) > 0 Or If InStr(1, hdr, "dmarc=pass", vbTextCompare) > 0 Or _ InStr(1, hdr, "X-MS-Exchange-Organization-AuthAs: Internal", vbTextCompare) > 0 Or _ InStr(1, hdr, "X-MS-Exchange-CrossTenant-AuthAs: Internal", vbTextCompare) > 0 Then Exit Function End If Set reFrom = New RegExp ' Set up RegExp to extract From header reFrom.pattern = "^\s*From:\s.*?<([^>]+)>" ' Match address inside angle brackets reFrom.IgnoreCase = True reFrom.Multiline = True reFrom.Global = False Set matches = reFrom.Execute(hdr) ' Execute regex on headers If matches.Count > 0 Then shownDom = LCase$(GetDomainFromEmail(matches(0).SubMatches(0))) ' Extract domain from From Else shownDom = "(none)" ' Fallback if no From found End If originDom = GetOriginatorDomainFromHeader(hdr) ' Extract oldest domain in Received headers If Len(originDom) = 0 Then originDom = "(unknown)" ' Fallback if origin not found '--- Allowlist logic: skip spoof check if sender or originator domain is trusted passList = Array("somedom") For Each passItem In passList If InStr(1, originDom, LCase$(passItem)) > 0 Then Exit Function End If Next passItem '--- Compare all 3 domains for mismatch mismatch = Not (EndsWithDomain(shownDom, actualDom) And _ EndsWithDomain(originDom, actualDom)) If mismatch Then IsSpoofHeader = True ' Flag as spoofed bannerText = "----------------------------------------------------------" & vbCrLf & _ "<br>WARNING: Possible header spoofing detected!" & vbCrLf & _ "<br>Displayed From domain: " & shownDom & vbCrLf & _ "<br>Actual sender domain: " & actualDom & vbCrLf & _ "<br>Originator domain: " & originDom & vbCrLf & _ "<br>----------------------------------------------------------" & vbCrLf bannerHtml = WARNING_MARKER & _ "<div style=""padding:10px;margin:0 0 10px 0;background:#c00;color:#fff;" & _ "font-family:Segoe UI,Arial,sans-serif;font-size:14px;font-weight:700;letter-spacing:.2px;" & _ "border-radius:4px;"">" & _ "<p style='margin:0;'>" & bannerText & "</p>" & _ "</div>" If Len(mi.htmlBody) > 0 Then If Not AlreadyTagged(mi.htmlBody) Then mi.htmlBody = InjectBannerIntoHtml(mi.htmlBody, bannerHtml) SafeSave mi End If Else If InStr(mi.body, bannerText) = 0 Then mi.body = bannerText & vbCrLf & String$(Len(bannerText), "=") & vbCrLf & vbCrLf & mi.body SafeSave mi End If End If End If LogMismatch mi, actualAddr, actualDom, shownDom, originDom, mismatch Exit Function FailSafe: MsgBox "ERROR: " & err.Description, vbCritical + vbOKOnly, "ERROR" Resume Next End Function Private Function GetHeaderRaw(ByVal mi As Outlook.mailItem) As String On Error Resume Next Dim pa As Outlook.PropertyAccessor ' Property accessor to read headers Set pa = mi.PropertyAccessor Const PR_HEADERS As String = "http://schemas.microsoft.com/mapi/proptag/0x007D001E" GetHeaderRaw = pa.GetProperty(PR_HEADERS) End Function Private Function GetSenderSmtpAddress(ByVal mi As Outlook.mailItem) As String On Error GoTo TryRaw Dim exu As Outlook.exchangeUser ' Exchange user object Dim raw As String ' Raw sender email Dim pa As Outlook.PropertyAccessor ' Property accessor to read SMTP address If Not mi.Sender Is Nothing Then If mi.Sender.AddressEntryUserType = olExchangeUserAddressEntry Or _ mi.Sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then Set exu = mi.Sender.GetExchangeUser If Not exu Is Nothing Then GetSenderSmtpAddress = exu.PrimarySmtpAddress Exit Function End If End If End If TryRaw: raw = mi.SenderEmailAddress If InStr(1, raw, "@") > 0 Then GetSenderSmtpAddress = raw Else Const PR_SMTP As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" Set pa = mi.PropertyAccessor On Error Resume Next GetSenderSmtpAddress = pa.GetProperty(PR_SMTP) On Error GoTo 0 End If End Function Private Function GetDomainFromEmail(ByVal address As String) As String Dim p As Long ' Position of "@" character p = InStrRev(address, "@") If p > 0 Then GetDomainFromEmail = Mid$(address, p + 1) End Function Private Function EndsWithDomain(ByVal candidate As String, ByVal rootDomain As String) As Boolean If candidate = rootDomain Then EndsWithDomain = True Exit Function End If If Right$(candidate, Len(rootDomain) + 1) = "." & rootDomain Then EndsWithDomain = True End If End Function Private Function AlreadyTagged(ByVal htmlOrText As String) As Boolean AlreadyTagged = (InStr(1, htmlOrText, WARNING_MARKER, vbTextCompare) > 0) End Function Private Function InjectBannerIntoHtml(ByVal html As String, ByVal bannerHtml As String) As String Dim lower As String ' Lowercase HTML string for matching Dim pos As Long ' Position of <body> tag Dim gt As Long ' Position of body tag's '>' If AlreadyTagged(html) Then InjectBannerIntoHtml = html Exit Function End If lower = LCase$(html) pos = InStr(1, lower, "<body", vbTextCompare) If pos > 0 Then gt = InStr(pos, html, ">") If gt > 0 Then InjectBannerIntoHtml = Left$(html, gt) & bannerHtml & Mid$(html, gt + 1) Exit Function End If End If InjectBannerIntoHtml = bannerHtml & html End Function Private Sub SafeSave(ByVal mi As Outlook.mailItem) On Error Resume Next mi.Save End Sub Private Sub LogMismatch(ByVal mi As Outlook.mailItem, ByVal actualAddr As String, ByVal actualDom As String, _ ByVal shownDom As String, ByVal originDom As String, ByVal didFlag As Boolean) On Error Resume Next Dim fso As FileSystemObject ' For file operations Dim ts0 As TextStream ' For creating file Dim ts As TextStream ' For appending log Set fso = New FileSystemObject If Not fso.FolderExists("C:\temp") Then fso.CreateFolder "C:\temp" If Not fso.FileExists(LOG_FILE) Then Set ts0 = fso.CreateTextFile(LOG_FILE, True, True) ts0.WriteLine "Timestamp,EntryID,Subject,Sender,SenderDomain,ShownDomain,OriginDomain,Decision" ts0.Close End If Set ts = fso.OpenTextFile(LOG_FILE, ForAppending, True, TristateTrue) ts.WriteLine Format$(Now, "yyyy-mm-dd hh:nn:ss") & "," & mi.EntryID & "," & Replace(mi.Subject, ",", " ") & "," & _ actualAddr & "," & actualDom & "," & shownDom & "," & originDom & "," & IIf(didFlag, "FLAG", "OK") ts.Close End Sub Private Function GetOriginatorDomainFromHeader(ByVal headerText As String) As String ' Parses Received headers line-by-line to safely extract the oldest sending domain Dim lines As Variant ' All lines from header Dim line As String ' Current line Dim block As String ' Accumulated Received block Dim receivedBlocks As Collection ' All Received: blocks Dim i As Long ' Line counter Dim hopLine As String ' Selected Received block Dim reFrom As RegExp ' Extract 'from' host Dim reDom As RegExp ' Extract domain from host Dim matches As MatchCollection ' Regex results Dim domain As String ' Final domain Set receivedBlocks = New Collection lines = Split(headerText, vbCrLf) For i = 0 To UBound(lines) line = Trim$(lines(i)) If LCase$(Left(line, 9)) = "received:" Then If Len(block) > 0 Then receivedBlocks.Add block block = line ElseIf Len(block) > 0 Then If line <> "" Then block = block & " " & line End If Next i If Len(block) > 0 Then receivedBlocks.Add block If receivedBlocks.Count = 0 Then Exit Function hopLine = receivedBlocks(receivedBlocks.Count) Set reFrom = New RegExp reFrom.pattern = "from\s+([^\s\(\);]+)" reFrom.IgnoreCase = True Set matches = reFrom.Execute(hopLine) If matches.Count = 0 Then Exit Function domain = matches(0).SubMatches(0) Set reDom = New RegExp reDom.pattern = "([a-z0-9.-]+\.[a-z]{2,})$" reDom.IgnoreCase = True Set matches = reDom.Execute(domain) If matches.Count > 0 Then GetOriginatorDomainFromHeader = LCase$(matches(0).SubMatches(0)) Else GetOriginatorDomainFromHeader = LCase$(domain) End If End Function