Set of VBA Macros to Parse and format DMARC reports

Description

Lets start by saying that if you are running a serious mail operation this is not what you are looking for. There are plenty of commercial suppliers who do a much more serious and functional product, and many of them do a free service for amateur users.

So why did I bother? Well, all the products I found were dependant on setting the rua record (describing the detail of DMARC is outside my scope here!) to their system, so that the DMARC reports go to their server and are processed by them. This is undoubtedly the way to go for anyone handling a serious amount of mail. But I only deal with tens of messages per month, and didn't want to bother with that!

So how does this work? Start by setting up the RUA record to point at a mailbox you have access to. The reports will come as messages, probably mainly from Google and MS, with attachments. The attachments may be zipped or gzipped. Download them to a folder and unzip them and you will get XML files with remarkably long file names like enterprise.protection.outlook.com![your domain]!1785801600!1785888000.xml Its not as cryptic as it looks, the numbers on the end are just unix timestamps. OK, now you have a folder full of xml files. Fire up word, run the macro PxmlOpenDocuments, you'll get a dialogue box where you can pick the files, select them and press OK. What you'll get is a word document with a very simplified subset of the data in tab delimited format. Look at in word, copy and paste to excel, whatever you like. Hopefully the vast majority will be passes, and you'll spot the odd fail which you'll probably want to investigate. But that too is beyond my scope here. I don't actually know much about this stuff!

I must apologise for the code. This is particularly rough and ready stuff, poorly commented and very crude. Its been a few years since I did much vba programming and boy was I rusty! I stole a few bits of example code but at least I didn't use AI. Its not very elegant. You could do better. Even *I* could do better, but I don't seem to need to. I spent about a day on it, should have been half that!

To use the macro suite paste the whole code section into an appropriate word template, either your main personal macro template, or else a custom one just for this. From there you could edit the ribbon to add buttons for one or more macros, or you could simply run the macro manually..

I've presented this as a code secton rather than a download. I think its all translated properly for that presentation, but if you try it and find any problems please let me know.

Change History

1. August 2026 - Initial Public Release

Code

'University of Illinois/NCSA Open Source License
'Copyright (c) 2026 Jim Champ
'All rights reserved.
'Jim's DMARC parser
'Developed by:      Jim Champ
'Permission is hereby granted, free of charge, to any person obtaining a
'copy of this software and associated documentation files (the "Software"),
'to deal with the Software without restriction, including without
'limitation the rights to use, copy, modify, merge, publish, distribute,
'sublicense, and/or sell copies of the Software, and to permit persons to
'whom the Software is furnished to do so, subject to the following
'conditions:
' * Redistributions of source code must retain the above copyright
'   notice, this list of conditions and the following disclaimers.
' * Redistributions in binary form must reproduce the above copyright
'   notice, this list of conditions and the following disclaimers in the
'   documentation and/or other materials provided with the distribution.
' * Neither the names of Jim Champ,
'   nor the names of its contributors may be used to endorse or promote
'   products derived from this Software without specific prior written
'   permission.
'   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
'   OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
'   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
'   IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR
'   ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
'   CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH
'   THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE.

Global XMLData$


Sub PxmlOpenDocuments()

    PxmlNewDoc

    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant
    Dim doc As Document
    
    ' Create a file picker dialog box
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = "Select Word Documents"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "DMARC Documents", "*.xml"
        
        ' Show the dialog box. If user clicks OK, proceed.
        If .Show = -1 Then
            For Each vrtSelectedItem In .SelectedItems
                'convery file to crlf (Google dcims are Unix formet)
                PxmlConvertLFtoCR (vrtSelectedItem)
                PxmlProcess (vrtSelectedItem)
                Debug.Print vrtSelectedItem
            Next vrtSelectedItem
        End If
    End With
    
    Set fd = Nothing
End Sub


Private Sub PxmlConvertLFtoCR(fileToConvert As String)
' I grabbed this from a post by a "Easy-XL Support" on the Mr-Excel forum
'https://www.mrexcel.com/board/threads/how-to-convert-unix-text-file-to-pc-text-file.485534/page-2
'I altered it a bit so all line ends end up as crlf
' many thanks to original author

On Error GoTo ConvertFileLFtoCR_Error
 
' get next available VB file handle
Dim fileNum As Integer
fileNum = FreeFile
 
' open the file (read/write access required)
Open fileToConvert For Binary As #fileNum
 
' read the file into a string variable
Dim fileBuffer As String
fileBuffer = String(LOF(fileNum), 0)
Get #fileNum, , fileBuffer

' change all crlf to carriage returns
fileBuffer = Replace(fileBuffer, vbCrLf, vbCr)
' change all line feeds to carriage returns
fileBuffer = Replace(fileBuffer, vbLf, vbCr)
' change all cr to crlf
fileBuffer = Replace(fileBuffer, vbCr, vbCrLf)
 
' write the file back to disk
Put #fileNum, 1, fileBuffer
 
' close the file
Close #fileNum
 
' Thank you. Please come again.
Exit Sub
 
ConvertFileLFtoCR_Error:
 
    MsgBox Err.Description
 
End Sub

Private Sub PxmlProcess(TheFile)

Dim OrgName$
Dim dkim_Status As Boolean
Dim spf_Status As Boolean
dkim_Status = False
spf_Status = False
Dim dkim_Domain$
Dim dkim_Result$
Dim spf_Domain$
Dim spf_Result$



fnum = FreeFile()
Open TheFile For Input As #fnum
    'This will need to be a loop but...

While Not EOF(fnum)
    'find ""
    Line Input #fnum, XMLData$
    Debug.Print XMLData$
     
    If PxmlFind(XMLData$, "org_name") Then
        Org_Name$ = PxmlStrip(XMLData$)
    End If
    
    If XMLData$ Like "**" Then
        End_Date$ = PxmlStrip(XMLData$)
    End If
        
    If PxmlFind(XMLData$, "source_ip") Then
        Src_IP$ = PxmlStrip(XMLData$)
    End If
    
    If PxmlFind(XMLData$, "envelope_to") Then
        env_To$ = PxmlStrip(XMLData$)
    End If
    If PxmlFind(XMLData$, "envelope_from") Then
        env_From$ = PxmlStrip(XMLData$)
    End If
    If PxmlFind(XMLData$, "header_from") Then
        hdr_From$ = PxmlStrip(XMLData$)
    End If
    
    If dkim_Status = True Then
        If PxmlFind(XMLData$, "domain") Then
            dkim_Domain$ = PxmlStrip(XMLData$)
        End If
        If PxmlFind(XMLData$, "result") Then
            dkim_Result$ = PxmlStrip(XMLData$)
        End If
    End If
    
    If spf_Status = True Then
        If PxmlFind(XMLData$, "domain") Then
            spf_Domain$ = PxmlStrip(XMLData$)
        End If
        If PxmlFind(XMLData$, "result") Then
            spf_Result$ = PxmlStrip(XMLData$)
        End If
    End If

    
    If XMLData$ Like "***" Then
        'we want to skip
    Else
        If PxmlFind(XMLData$, "dkim") Then
            dkim_Status = True
        End If
        If PxmlFind(XMLData$, "/dkim") Then
            dkim_Status = False
        End If
    End If
    
    If XMLData$ Like "***" Then
        'we want to skip
    Else
        If PxmlFind(XMLData$, "spf") Then
            spf_Status = True
        End If
        If PxmlFind(XMLData$, "/spf") Then
            spf_Status = False
        End If
    End If
    
    If PxmlFind(XMLData$, "/record") Then
        'We have a new record
        'print the output
        Selection.TypeText Text:=Org_Name$
        Selection.TypeText Text:=vbTab
        
        'EndDate$ is in Unix 10char format
        
        If Len(End_Date$) = 10 Then
            Selection.TypeText Text:=DateAdd("s", CDbl(End_Date$), "1/1/1970 00:00:00")
        End If
            
        Selection.TypeText Text:=vbTab
        
        Selection.TypeText Text:=Src_IP$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=env_To$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=env_From$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=hdr_From$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=dkim_Domain$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=dkim_Result$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=spf_Domain$
        Selection.TypeText Text:=vbTab
        Selection.TypeText Text:=spf_Result$
        Selection.TypeText Text:=vbCrLf
        
        'blank all vars except org name
        
        Src_IP$ = ""
        env_To$ = ""
        env_From$ = ""
        hdr_From$ = ""
        dkim_Domain$ = ""
        dkim_Result$ = ""
        spf_Domain$ = ""
        spf_Result$ = ""
        
        
    End If
Wend
Close
End Sub

Private Sub PxmlNewDoc()
	'create a word file for the output
    Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
    If Selection.PageSetup.Orientation = wdOrientPortrait Then
        Selection.PageSetup.Orientation = wdOrientLandscape
    End If
    'and write the column headers
    Selection.TypeText Text:="Org_Name"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="Date"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="Src_IP"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="Env_To"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="Env_From"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="Hdr_From"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="dkim_Domain"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="dkim_Result"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="spf_Domain"
    Selection.TypeText Text:=vbTab
    Selection.TypeText Text:="spf_Result"
    Selection.TypeText Text:=vbCrLf


End Sub


Private Function PxmlFind(Aline As String, Ssearch As String)
If Aline Like "*<" & Ssearch & "*" Then
    PxmlFind = True
Else
    PxmlFind = False
End If
End Function


Private Function PxmlStrip(Aline As String)
If Aline Like "*<*>*" Then

    sttpos = InStr(Aline, "<")
    Aline = Mid(Aline, sttpos + 1)
    'strips off all up to first
    endpos = InStr(Aline, ">")
    Aline = Mid(Aline, endpos + 1)
    'strips off first tag
    
    nextpos = InStr(Aline, "<")
    Aline = Left(Aline, nextpos - 1)
    PxmlStrip = Aline
Else
    Aline = vbNull
End If
End Function

---

These snippets and utilities are licensed under the University of Illinois/NCSA Open Source License. Here is the text of the license as it applies to this code.

To contact the writer you may as well use Facebook, or if you prefer use Linked In. I do have a mail form off my home page too.

HTML check . CSS check

© Jim Champ, last edit