Header Statistics for outlook client

I currently have an antispam solution that is working fine.  However I recently have had a spike in the amount of email showing up in my junk email folder.  I believe if had the right data at hand I could probably block a few ips and nail 80% of the volume.  In order to do that I need to gather some statistics on the origin ips of items in my junk email.  I would like to find a tool that would allow me to point it my junk email folder and have it dig through all the messages headers an tally up the number of emails from each ip.  Alternatively if I could just export an excel file with the ip for each message then I can do the rollup myself.

Anyone aware of such a tool?  I googled for 30 minutes but there are so many antispam tools out there that I can't wade through it all. thanks
vizientAsked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
David LeeConnect With a Mentor Commented:
Ok, here's the code for this.  I'm not sure how accurate the results are because I've yet to find a hard and fast rule for parsing the sender's IP address from the header.  The principle I've applied here is it's the last bracketed IP address in line unless that address is 127.0.0.1 in which case it's the next to last address.

Follow these instructions to add the code to Outlook.

1.  Start Outlook
2.  Click Tools > Macro > Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects
4.  If not already expanded, expand Modules
5.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module.
6.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
7.  Edit the code as needed.  I included comments wherever something needs to or can change
8.  Click the diskette icon on the toolbar to save the changes
9.  Close the VB Editor

To use this

1.  Select one or more messages
2.  Run the macro SearchInetHeaderForIP

The output is a text file with one address per line.  You can import that into Excel, Access, or some application that can sort and sum the results.
Sub SearchInetHeaderForIP()
    Dim olkItem As Outlook.MailItem, objRegEx As Object, colMatches As Object, objFSO As Object, objFile As Object, intIndex As Integer
    Dim strHeader As String, strTemp As String, strMatches As String
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "\[\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\]"
        .Global = True
    End With
    For Each olkItem In Application.ActiveExplorer.Selection
        strHeader = GetInetHeaders(olkItem)
        Set colMatches = objRegEx.Execute(strHeader)
        For intIndex = (colMatches.count - 1) To 1 Step -1
            strTemp = Replace(colMatches.Item(intIndex), "[", "")
            strTemp = Replace(strTemp, "]", "")
            If strTemp <> "127.0.0.1" Then
                strMatches = strMatches & strTemp & vbCrLf
                Exit For
            End If
        Next
        Set colMatches = Nothing
        strTemp = ""
    Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Edit the file name and path on the next line'
    Set objFile = objFSO.CreateTextFile("c:\eeTesting\SenderIP.txt")
    objFile.Write strMatches
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set colMatches = Nothing
    Set objRegEx = Nothing
    Set olkItem = Nothing
    msgbox "Done"
End Sub

Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function

Open in new window

0
 
David LeeCommented:
Hi, vizient.

I might be able to help.  What version of Outlook are you using?
0
 
vizientAuthor Commented:
2007
0
Free tool for managing users' photos in Office 365

Easily upload multiple users’ photos to Office 365. Manage them with an intuitive GUI and use handy built-in cropping and resizing options. Link photos with users based on Azure AD attributes. Free tool!

 
vizientAuthor Commented:
I think this is very close! I stepped through the code in debug mode and though your pulling ip addresses out...it appears that some of the time you are parsing out  their internal relays  (internal to sending company) occuring through multiple servers and these ips are being picked up.  I would attempt to modify the code myself but its been ages since I have touch regular expressions.  Heres a thought though the line where the ip I want should always look like this
([129.35.117.152]) by secure.vizient.com

where the by secure.vizient.com is always the same.  Could you key up on that?  Obviously to test you would need to find something static like that on an incoming email of your own.
0
 
David LeeCommented:
Ok, try this.
Sub SearchInetHeaderForIP()
    Dim olkItem As Outlook.MailItem, objRegEx As Object, colMatches As Object, objFSO As Object, objFile As Object, intIndex As Integer
    Dim strHeader As String, strTemp As String, strMatches As String
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "\(\[\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\]\) by secure.vizient.com"
        .Global = True
    End With
    For Each olkItem In Application.ActiveExplorer.Selection
        strHeader = GetInetHeaders(olkItem)
        Set colMatches = objRegEx.Execute(strHeader)
        For intIndex = 0 To (colMatches.count - 1) Step -1
            strTemp = Replace(colMatches.Item(intIndex), "[", "")
            strTemp = Replace(strTemp, "]", "")
            If strTemp <> "127.0.0.1" Then
                strMatches = strMatches & strTemp & vbCrLf
                Exit For
            End If
        Next
        Set colMatches = Nothing
        strTemp = ""
    Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Edit the file name and path on the next line'
    Set objFile = objFSO.CreateTextFile("c:\eeTesting\SenderIP.txt")
    objFile.Write strMatches
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set colMatches = Nothing
    Set objRegEx = Nothing
    Set olkItem = Nothing
    msgbox "Done"
End Sub

Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function

Open in new window

0
 
vizientAuthor Commented:
got it! Thanks!
0
 
David LeeCommented:
You're welcome.
0
All Courses

From novice to tech pro — start learning today.