VBA macro to get IPs from outlook email Friday, Apr 4 2008

I found this script some where and tweaked it.

A VBA Macro button (for Outlook 2003) was created to easily view IPs and data from email messages – specifically spam.
I keep most spam in a separate folder.  This was i can select all messages (*not locally delivered (**to be added later)) and with one click, view all the ips in a nice .csv which is easily impoted in to excel.

-grr.. is there no <code> tag?
[edit - updated formatting usign this: show/hide kitchen sink -> pre-formatted text]

=====begin code
Sub DBsGetAllHeaderIPs()
'Takes the currently selected messages,
' copies the IPs from headers
' opens notepad with the headers as well.
    'Dim dataObject As MSForms.dataObject
    Dim strInternetHeaders As String
   
    Dim objSession As MAPI.Session
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
   
    Set objSession = CreateObject("MAPI.Session")
    Set objExplorer = ThisOutlookSession.ActiveExplorer
    Set objSelection = objExplorer.Selection
   
    Dim objItem As Outlook.MailItem
    Dim objMessage As MAPI.Message
Dim strLine As String
Dim strAll As String
Dim strTemp As String
Dim strSub As String
Dim strFrom As String
Dim strDate As String
Dim strIP As String
Dim intS As Integer
Dim intE As Integer
   
objSession.Logon "", "", False, False
strAll = ""
Dim item As Outlook.MailItem
For Each item In objSelection
   
  '  Set objItem = objSelection.Item(1)
    Set objItem = item
    
    Set objMessage = objSession.GetMessage(objItem.EntryID, objItem.Parent.StoreID)
       
    'add error checking for local exchange
    strInternetHeaders = objMessage.Fields.item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
 
 
'must use temp text file??
    Dim fso As New FileSystemObject
    Dim ts As TextStream
    Dim strHeaderFilename As String
   
    strHeaderFilename = "c:_tmp.header.txt"
   
    Set ts = fso.CreateTextFile(strHeaderFilename, True)
    ts.Write (strInternetHeaders)
    ts.Close
'end of text file??
'open file to read
    Dim oFSO As New FileSystemObject
    Dim oFS
    Set oFS = oFSO.OpenTextFile(strHeaderFilename)
   
   
  strIP = ""
'read lines for data
    Do Until oFS.AtEndOfStream
        strLine = oFS.ReadLine
        If (Left(strLine, Len("Received:")) = "Received:") Then
           strTemp = strLine
           intS = InStr(strTemp, "[")
           If intS <> 0 Then
        'find IP and date
               intE = InStr(strTemp, "]")
               strIP = Mid(strTemp, intS + 1, intE - intS - 1)
              
               intS = InStr(strTemp, ";")
               strDate = Mid(strTemp, intS + 7)
           End If
        End If
        If (Left(strLine, Len("From:")) = "From:") Then strFrom = Right(strLine, Len(strLine) - 6)
        If (Left(strLine, Len("Subject:")) = "Subject:") Then strSub = Right(strLine, Len(strLine) - 9)
    Loop
 
    strAll = strAll & strIP & "," & strDate & "," & strFrom & "," & strSub & vbCrLf
Next item
     Dim strInfoFilename As String
'    strInfoFilename = CStr(Month(Now())) & "-" & CStr(Day(Now())) & "-" & CStr(Time(Hour(Now()), Minute(Now()), Second(Now()))) & ".header.txt"
    strInfoFilename = "c:" & Month(Now()) & "-" & Day(Now()) & "_" & Hour(Now()) & "-" & Minute(Now()) & ".header.csv"
   
    Set ts = fso.OpenTextFile(strInfoFilename, ForWriting, True)
    ts.Write (strAll)
    ts.Close
   
    Shell "notepad.exe " & strInfoFilename
End Sub
=====end of code

so basically, it opens a MAPI session and reads the full message header.  the header is scanned for IP and other info then saved to a text file.

Good ol’   CdoPR_TRANSPORT_MESSAGE_HEADERS