Option Explicit

Sub TestScrubbed()
Dim olMsg As MailItem
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select
    CheckScrubbed olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub CheckScrubbed(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 03 Feb 2021
Const strFind As String = "Total Scrubbed Deferred: "
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim sText As String
Dim sMsg As String
Dim i As Integer
Dim oCol As Collection
    With olItem
        Set oCol = New Collection
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(findText:=strFind & "[0-9]{1,}", MatchWildcards:=True)
                sText = Replace(oRng.Text, strFind, "")
                Select Case True
                    Case CInt(sText) = 0
                        olItem.UnRead = False
                    Case CInt(sText) > 0
                        On Error Resume Next
                        oCol.Add oRng.Text, oRng.Text
                End Select
                .collapse 0
            Loop
            If oCol.Count > 0 Then
                olItem.UnRead = True
                For i = 1 To oCol.Count
                    If i = 1 Then sMsg = oCol(i)
                    If i > 1 Then sMsg = sMsg & vbCr & oCol(i)
                Next i
                MsgBox sMsg, vbExclamation
            End If
        End With
    End With
lbl_Exit:
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub