Outlook VBA Spoof check - checks sender email against originator email - RED banner if fail
Attribute VB_Name = "otl_SpoofCheck"
' File: Module AntiSpoof_Enhanced.bas
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
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)
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, actualDom As String
Dim hdr As String, shownDom As String, shownAddr As String
Dim originDom As String, mismatch As Boolean
Dim bannerText As String, bannerHtml As String
Dim passList As Variant, passItem As Variant
Dim reasons As Collection, decision As String
Dim spfPass As Boolean, dkimPass As Boolean, dmarcPass As Boolean, isInternal As Boolean
Dim unauth As Boolean, badLocal As Boolean
IsSpoofHeader = False
actualAddr = GetSenderSmtpAddress(mi)
If Len(actualAddr) = 0 Then Exit Function
actualDom = LCase$(GetDomainFromEmail(actualAddr))
hdr = GetHeaderRaw(mi)
If Len(hdr) = 0 Then Exit Function
' Auth status (why: we must flag unauthenticated even if domains match)
ParseAuthStatus hdr, spfPass, dkimPass, dmarcPass, isInternal
unauth = (Not spfPass And Not dkimPass And Not dmarcPass And Not isInternal)
' Extract shown From address (full) and domain
shownAddr = GetFromAddressFromHeader(hdr)
If Len(shownAddr) > 0 Then
shownDom = LCase$(GetDomainFromEmail(shownAddr))
Else
shownDom = "(none)"
End If
' Oldest hop domain
originDom = GetOriginatorDomainFromHeader(hdr)
If Len(originDom) = 0 Then originDom = "(unknown)"
' Allowlist: skip SPOOF mismatch if trusted relay/sender (why: reduce false positives)
passList = Array("useapdvt27ps2", "exclaimer.net", "gallowayus.com")
Dim spoofBypass As Boolean: spoofBypass = False
For Each passItem In passList
If InStr(1, actualDom, LCase$(passItem)) > 0 Or _
InStr(1, originDom, LCase$(passItem)) > 0 Then
spoofBypass = True
Exit For
End If
Next passItem
' Domain mismatch (only meaningful when not bypassed)
If Not spoofBypass Then
mismatch = Not (EndsWithDomain(shownDom, actualDom) And _
EndsWithDomain(originDom, actualDom))
Else
mismatch = False
End If
' Suspicious local-part like "Norepoy" (typo of "Noreply") on shown or actual
badLocal = IsNorepoyAddr(shownAddr) Or IsNorepoyAddr(actualAddr)
' Reasons aggregation
Set reasons = New Collection
If mismatch Then reasons.Add "Possible header spoofing (domain mismatch)"
If unauth Then reasons.Add "Unauthenticated sender (no SPF/DKIM/DMARC pass)"
If badLocal Then reasons.Add "Suspicious mailbox: looks like 'norepoy@' (typo of 'noreply@')"
If reasons.Count > 0 Then
IsSpoofHeader = True
bannerText = "----------------------------------------------------------" & vbCrLf & _
"<br>WARNING: Message flagged for review:" & vbCrLf & _
"<br>Displayed From: " & IIf(Len(shownAddr) > 0, shownAddr, "(unknown)") & vbCrLf & _
"<br>Displayed From domain: " & shownDom & vbCrLf & _
"<br>Actual sender: " & actualAddr & vbCrLf & _
"<br>Actual sender domain: " & actualDom & vbCrLf & _
"<br>Originator domain: " & originDom & vbCrLf & _
"<br>Authentication: SPF=" & UCase$(PassStr(spfPass)) & _
" DKIM=" & UCase$(PassStr(dkimPass)) & _
" DMARC=" & UCase$(PassStr(dmarcPass)) & _
IIf(isInternal, " (Internal)", "") & vbCrLf & _
"<br>Reason(s): " & JoinCollection(reasons, "; ") & 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
' Decision string for the log
decision = BuildDecisionString(mismatch, unauth, badLocal, spfPass, dkimPass, dmarcPass, isInternal, spoofBypass)
LogEvent mi, actualAddr, actualDom, shownDom, originDom, decision
Exit Function
FailSafe:
MsgBox "ERROR: " & Err.Description, vbCritical + vbOKOnly, "ERROR"
Resume Next
End Function
' ---------- Header/util helpers ----------
Private Function GetHeaderRaw(ByVal mi As Outlook.mailItem) As String
On Error Resume Next
Dim pa As Outlook.PropertyAccessor
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
Dim raw As String
Dim pa As Outlook.PropertyAccessor
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 GetFromAddressFromHeader(ByVal headerText As String) As String
' why: we need full address to analyze suspicious local-part
Dim reFrom As RegExp, m As MatchCollection
Set reFrom = New RegExp
reFrom.pattern = "^\s*From:\s.*?<([^>]+)>" ' prefer angle-brackets
reFrom.IgnoreCase = True: reFrom.Multiline = True: reFrom.Global = False
Set m = reFrom.Execute(headerText)
If m.Count > 0 Then
GetFromAddressFromHeader = m(0).SubMatches(0)
Exit Function
End If
' fallback � plain address without <>
reFrom.pattern = "^\s*From:\s*([^\r\n]+)$"
Set m = reFrom.Execute(headerText)
If m.Count > 0 Then
GetFromAddressFromHeader = Trim$(StripDisplayName(m(0).SubMatches(0)))
End If
End Function
Private Function StripDisplayName(ByVal fromLine As String) As String
Dim p As Long
p = InStr(fromLine, "<")
If p > 0 Then
StripDisplayName = Mid$(fromLine, p + 1, InStr(fromLine, ">") - p - 1)
Else
StripDisplayName = fromLine
End If
End Function
Private Sub ParseAuthStatus( _
ByVal headerText As String, _
ByRef spfPass As Boolean, _
ByRef dkimPass As Boolean, _
ByRef dmarcPass As Boolean, _
ByRef isInternal As Boolean)
' why: tolerant parse of common auth headers
Dim h As String: h = LCase$(headerText)
spfPass = (InStr(1, h, "spf=pass") > 0)
dkimPass = (InStr(1, h, "dkim=pass") > 0)
dmarcPass = (InStr(1, h, "dmarc=pass") > 0)
isInternal = (InStr(1, h, "x-ms-exchange-organization-authas: internal") > 0 Or _
InStr(1, h, "x-ms-exchange-crosstenant-authas: internal") > 0)
End Sub
Private Function PassStr(ByVal passed As Boolean) As String
PassStr = IIf(passed, "pass", "fail")
End Function
Private Function GetDomainFromEmail(ByVal address As String) As String
Dim p As Long
p = InStrRev(address, "@")
If p > 0 Then GetDomainFromEmail = Mid$(address, p + 1)
End Function
Private Function GetLocalFromEmail(ByVal address As String) As String
Dim p As Long
p = InStr(address, "@")
If p > 0 Then GetLocalFromEmail = Left$(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, pos As Long, gt As Long
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
' ---------- Logging ----------
Private Sub LogEvent( _
ByVal mi As Outlook.mailItem, _
ByVal actualAddr As String, _
ByVal actualDom As String, _
ByVal shownDom As String, _
ByVal originDom As String, _
ByVal decision As String)
On Error Resume Next
Dim fso As FileSystemObject, ts0 As TextStream, ts As TextStream
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 & "," & decision
ts.Close
End Sub
Private Function BuildDecisionString( _
ByVal mismatch As Boolean, _
ByVal unauth As Boolean, _
ByVal badLocal As Boolean, _
ByVal spfPass As Boolean, _
ByVal dkimPass As Boolean, _
ByVal dmarcPass As Boolean, _
ByVal isInternal As Boolean, _
ByVal spoofBypass As Boolean) As String
Dim parts As Collection: Set parts = New Collection
If mismatch Then parts.Add "FLAG_SPOOF"
If unauth Then parts.Add "FLAG_UNAUTH"
If badLocal Then parts.Add "FLAG_BADLOCAL"
If spoofBypass Then parts.Add "BYPASS_SPOOF_ALLOWLIST"
If isInternal Then parts.Add "AUTH_INTERNAL"
If spfPass Then parts.Add "SPF_PASS" Else parts.Add "SPF_FAIL"
If dkimPass Then parts.Add "DKIM_PASS" Else parts.Add "DKIM_FAIL"
If dmarcPass Then parts.Add "DMARC_PASS" Else parts.Add "DMARC_FAIL"
BuildDecisionString = JoinCollection(parts, "|")
End Function
' ---------- Domain/Received parsing ----------
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, line As String, block As String
Dim receivedBlocks As Collection, i As Long, hopLine As String
Dim reFrom As RegExp, reDom As RegExp, matches As MatchCollection
Dim domain As String
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
' ---------- Suspicious local-part detection ----------
Private Function IsNorepoyAddr(ByVal address As String) As Boolean
' why: catch the common lookalike "norepoy@" (o/y vs l/y)
If Len(address) = 0 Then Exit Function
Dim localPart As String: localPart = LCase$(GetLocalFromEmail(address))
If Len(localPart) = 0 Then Exit Function
' Exact bad string:
If Left$(localPart, 7) = "norepoy" Then
IsNorepoyAddr = True
Exit Function
End If
' Fuzzy: single-character edit distance from "noreply" at last character position,
' to catch minor swaps like "noreplv", "noreplx". Keep conservative to avoid FPs.
If Len(localPart) >= 7 Then
Dim cand As String
cand = Left$(localPart, 6) & Mid$(localPart, 7, 1)
If Left$(cand, 6) = "norepl" And Mid$(cand, 7, 1) <> "y" Then
IsNorepoyAddr = True
End If
End If
End Function
' ---------- Small helpers ----------
Private Function JoinCollection(ByVal coll As Collection, ByVal sep As String) As String
Dim i As Long, s As String
For i = 1 To coll.Count
s = s & coll(i)
If i < coll.Count Then s = s & sep
Next i
JoinCollection = s
End Function
Comments
Post a Comment