Nov 4 2010

Retreiving Internet Headers Using VBA in Outlook 2007/2010


This post is for Leif Hurst (@leifhurst on Twitter). Leif posted this tweet today:

#outlook 2010 is awesome… all my 2003 and 2007 CDO dependent scripts no longer working… frustrating!! Need to extract headers to email.

With Outlook 2003 and earlier a script had to use CDO (Collaboration Data Objects) to access those item properties that were not exposed by Outlook’s object model. Outlook 2007 changed this by introducing the Property Accessor object. This is a built-in object that allows a script to retrieve unexposed item properties without CDO. The function below takes a mail item and returns the internet headers as a string.

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

76 comments on “Retreiving Internet Headers Using VBA in Outlook 2007/2010”

  1. Hi,
    I am attempting to display the internet header information of a outlook message I created in word VB prior to sending the message. I used your code above however the string return from olkPA.GetProperty is null, can you help? I attached the code here, skip down to my comment ‘get internet header to see where your code starts.
    THK

    Sub emailmergewithattachments()
    Dim Source As Document, Maillist As Document, TempDoc As Document
    Dim Datarange As Range
    Dim i As Long, j As Long
    Dim bStarted As Boolean
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
    Dim mysubject As String, message As String, title As String
    Const PR_TRANSPORT_MESSAGE_HEADERS = “http://schemas.microsoft.com/mapi/proptag/0x007D001E”
    Dim olkPA As Outlook.PropertyAccessor
    Dim resultInetHeaders As String

    Set Source = ActiveDocument
    ‘ Check if Outlook is running. If it is not, start Outlook
    On Error Resume Next
    Set oOutlookApp = GetObject(, “Outlook.Application”)
    If Err 0 Then
    Set oOutlookApp = CreateObject(“Outlook.Application”)
    bStarted = True
    End If
    ‘ Open the catalog mailmerge document
    With Dialogs(wdDialogFileOpen)
    .Show
    End With
    Set Maillist = ActiveDocument
    ‘ Show an input box asking the user for the subject to be inserted into the email messages
    message = “Enter the subject to be used for each email message.” ‘ Set prompt.
    title = ” Email Subject Input” ‘ Set title.
    ‘ Display message, title
    mysubject = InputBox(message, title)
    ‘ Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
    ‘ extracting the information to be included in each email.
    For j = 1 To Source.Sections.Count – 1
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
    .Subject = mysubject
    .Body = Source.Sections(j).Range.Text
    Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
    Datarange.End = Datarange.End – 1
    .To = Datarange
    For i = 2 To Maillist.Tables(1).Columns.Count
    Set Datarange = Maillist.Tables(1).Cell(j, i).Range
    Datarange.End = Datarange.End – 1
    .Attachments.Add Trim(Datarange.Text), olByValue, 1
    Next i
    ‘get internet header
    Set olkPA = .PropertyAccessor
    resultInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    .Send
    End With
    Set olkPA = Nothing
    Set oItem = Nothing
    Next j
    Maillist.Close wdDoNotSaveChanges
    ‘ Close Outlook if it was started by this macro.
    If bStarted Then
    oOutlookApp.Quit
    End If
    MsgBox Source.Sections.Count – 1 & ” messages have been sent.”
    ‘Clean up
    Set oOutlookApp = Nothing
    End Sub

    Reply

  2. Hi David,
    I have a VBA sub in Outlook 2007 to extract emails that invalid, it run well with email items, but cant run with email reports (Read/Not read). So i like to make VBA to do this. When i add your VBA function to my sub, i was not run perfectly. Can you correct it for me. Thank you.

    Sub testing()
'Extract_Not_Read_Report Use for Outlook
'read mails in Inbox folfer

Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
    Dim strheader As String
   

Dim stremBody As String
Dim stremSubject As String


Dim x As Long
Dim xlApp As Object 'Excel.Application
Dim xlRng As Object 'Excel.Range
Dim xlwkbk As Object 'Excel.Workbook
Dim xlwksht As Object 'Excel.Worksheet


Dim olApp As Outlook.Application
Set olApp = Outlook.Application

Dim olExp As Outlook.Explorer
Set olExp = olApp.ActiveExplorer

Dim olFolder As Outlook.MAPIFolder
Set olFolder = olExp.CurrentFolder

Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")

 
'Open Excel
Set xlApp = GetExcelApp
xlApp.Visible = True
If xlApp Is Nothing Then GoTo ExitProc
 
Set xlwkbk = xlApp.Workbooks.Add
Set xlwksht = xlwkbk.Sheets(1)
Set xlRng = xlwksht.Range("A1")
xlRng.Value = "Was Read email addresses"

 
'Set count of email objects
Dim count As Long
count = olFolder.Items.count
 
'counter for excel sheet
Dim i As Long
i = 0

'counter for emails
x = 1
 

 For Each olItem In olFolder.Items
        strheader = GetInetHeaders(olItem)
        
    xlApp.StatusBar = x & " of " & count & " emails completed"
    
    stremBody = olItem.Body
    stremSubject = olItem.Subject


    'Check for keywords in email before extracting address
  If InStr(1, olItem.Subject, "not read", vbTextCompare) > 0 Then
        'MsgBox ("finding email: " & stremBody)
        regEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
        regEx.IgnoreCase = True
        regEx.MultiLine = False
        Set olMatches = regEx.Execute(strheader)

        
                  
        For Each match In olMatches
            xlwksht.Cells(i + 2, 1).Value = match
            i = i + 1
        Next match
        'TODO move or mark the email that had the address extracted
 
    Else
        'To view the items that aren't being parsed uncomment the following line
        'MsgBox (stremBody)
    End If
 
    x = x + 1
Next olItem

xlApp.ScreenUpdating = True

 
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set emItm = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub

Function GetExcelApp() As Object
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0
End Function


Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' https://techniclee.wordpress.com/
    ' 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
    Reply

    • Hi, Phuong Lee.

      I see a couple of problems. On line #5 the code is declaring olItem to be of type Outlook.MailItem. The problem with this is that reports aren’t of type MailItem. They are of type ReportItem. When the code reads a report and tries to load it into olItem it’s going to cause a type mismatch error. The solution to this is to declare olItem to be of type Object. The same problem occurs again on line #57 where the code calls the GetInetHeaders function and passes it olItem. Here again when the code is processing a report olItem is going to be of type ReportItem while GetInetHeaders is expecting an object of type MailItem. The result is another type mismatch. This time we can’t solve the problem by changing Outlook.MailItem to Object because ReportItem objects don’t have an internet header. The solution is to add a conditional statement that checks to see what type of item (i.e. MailItem or ReportItem) the code has read and only call GetInetHeaders if the item is of type MailItem. To do that, replace line #57 with this

      If olItem.Class = olMail Then 
    strheader = GetInetHeaders(olItem)
Else
    strHeader = ""
End If

      The above aside, what are you trying to accomplish? If the goal is to collect the addresses of the report’s sender, then there’s another solution. Let me know if that’s what you want and I’ll post the code for doing that.

    • Hi David,
      Thank you very much for your reply.
      Exactly. My goal is to collect the addresses of the report’s sender (both email items and report items) with condition statement on keyword (on subject, body), i think you have saw in my code.
      I really need your help. I look forward seeing your code.
      Again, Thanks.

    • Hi, Phuong Lee.

      This version extracts the sender’s SMTP address for both mail and report items. It also does it without having to read the internet headers. Please test this version and let me know if it does what you wanted.

      Sub Testing()
    'Extract_Not_Read_Report Use for Outlook
    'read mails in Inbox folder
    
    Dim olItem As Object
    
    Dim stremBody As String
    Dim stremSubject As String
    Dim stremSender As String
    
    Dim x As Long
    Dim xlApp As Object 'Excel.Application
    Dim xlRng As Object 'Excel.Range
    Dim xlwkbk As Object 'Excel.Workbook
    Dim xlwksht As Object 'Excel.Worksheet
    
    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application
    
    Dim olExp As Outlook.Explorer
    Set olExp = olApp.ActiveExplorer
    
    Dim olFolder As Outlook.MAPIFolder
    Set olFolder = olExp.CurrentFolder
       
    'Open Excel
    Set xlApp = GetExcelApp
    xlApp.Visible = True
    If xlApp Is Nothing Then GoTo ExitProc
    
    Set xlwkbk = xlApp.Workbooks.Add
    Set xlwksht = xlwkbk.Sheets(1)
    Set xlRng = xlwksht.Range("A1")
    xlRng.value = "Was Read email addresses"
    
    'Set count of email objects
    Dim count As Long
    count = olFolder.Items.count
    
    'counter for excel sheet
    Dim i As Long
    i = 0
    
    'counter for emails
    x = 1
    
    'Read the items in the folder
    For Each olItem In olFolder.Items
        Select Case olItem.Class
            Case olMail, olReport
                If InStr(1, olItem.Subject, "not read", vbTextCompare) > 0 Then
                    stremBody = olItem.Body
                    stremSubject = olItem.Subject
                    stremSender = SMTP2007(olItem)
                    x = x + 1
                End If
        End Select
        xlApp.StatusBar = x & " of " & count & " emails completed"
    Next olItem
    
    xlApp.ScreenUpdating = True
    
ExitProc:
    Set xlRng = Nothing
    Set xlwksht = Nothing
    Set xlwkbk = Nothing
    Set xlApp = Nothing
    Set emItm = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Function GetExcelApp() As Object
    ' always create new instance
    On Error Resume Next
    Set GetExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0
End Function

Function SMTP2007(olkMsg As Object) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

    • Hi David,
      I tested your code. But you have removed the code to write to excel, so extract value in excel file = nothing.
      Please help me put it back to work perfectly.
      I am grateful to you about that.

    • Hi David,
      I added your SMTP2007 function, put the code to write to excel following: but extract nothing.
      Sub Testing()

      Dim stremBody As String
      Dim stremSubject As String

      Dim x As Long
      Dim xlApp As Object ‘Excel.Application
      Dim xlRng As Object ‘Excel.Range
      Dim xlwkbk As Object ‘Excel.Workbook
      Dim xlwksht As Object ‘Excel.Worksheet

      Dim olApp As Outlook.Application
      Set olApp = Outlook.Application

      Dim olExp As Outlook.Explorer
      Set olExp = olApp.ActiveExplorer

      Dim olFolder As Outlook.MAPIFolder
      Set olFolder = olExp.CurrentFolder

      Dim regEx As Object
      Set regEx = CreateObject(“VBScript.RegExp”)

      ‘Open Excel
      Set xlApp = GetExcelApp
      xlApp.Visible = True
      If xlApp Is Nothing Then GoTo ExitProc

      Set xlwkbk = xlApp.Workbooks.Add
      Set xlwksht = xlwkbk.Sheets(1)
      Set xlRng = xlwksht.Range(“A1”)
      xlRng.Value = “Bounced email addresses”

      ‘Set count of email objects
      Dim count As Long
      count = olFolder.Items.count

      ‘counter for excel sheet
      Dim i As Long
      i = 0

      ‘counter for emails
      x = 1

      Dim obj As Object
      For Each obj In olFolder.Items
      xlApp.StatusBar = x & ” of ” & count & ” emails completed”

      stremBody = obj.Body
      stremSubject = obj.Subject
      stremSender = SMTP2007(obj)

      ‘Check for keywords in email before extracting address
      If InStr(1, obj.Subject, “Not read”, vbTextCompare) > 0 Then
      ‘MsgBox (“finding email: ” & stremBody)
      regEx.Pattern = “\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b”
      regEx.IgnoreCase = True
      regEx.MultiLine = False
      Set olMatches = regEx.Execute(stremSender)

      For Each match In olMatches
      xlwksht.Cells(i + 2, 1).Value = match
      i = i + 1
      Next match
      ‘TODO move or mark the email that had the address extracted

      Else
      ‘To view the items that aren’t being parsed uncomment the following line
      ‘MsgBox (stremBody)
      End If

      x = x + 1
      Next obj

      xlApp.ScreenUpdating = True

      ExitProc:
      Set xlRng = Nothing
      Set xlwksht = Nothing
      Set xlwkbk = Nothing
      Set xlApp = Nothing
      Set emItm = Nothing
      Set olFolder = Nothing
      Set olNS = Nothing
      Set olApp = Nothing
      End Sub

      Function GetExcelApp() As Object
      ‘ always create new instance
      On Error Resume Next
      Set GetExcelApp = CreateObject(“Excel.Application”)
      On Error GoTo 0
      End Function

      Function SMTP2007(olkMsg As Object) As String
      Dim olkPA As Outlook.propertyAccessor
      On Error Resume Next
      Set olkPA = olkMsg.propertyAccessor
      SMTP2007 = olkPA.GetProperty(“http://schemas.microsoft.com/mapi/proptag/0x5D01001E”)
      On Error GoTo 0
      Set olkPA = Nothing
      End Function

    • Hi, Phuong Lee.

      If all you want is the sender’s email address, then you don’t need the regex code. That’s why I removed it. Also, while the original code is pulling out the message/report’s subject and body, I don’t see it ever being written to the spreadsheet. I’ve modified the code I uploaded earlier to write the sender to the spreadsheet. Please try this version and let me know if it does what you wanted.

      Sub Testing()
    'Extract_Not_Read_Report Use for Outlook
    'read mails in Inbox folder
     
    Dim olItem As Object
     
    Dim stremBody As String
    Dim stremSubject As String
    Dim stremSender As String
     
    Dim x As Long
    Dim xlApp As Object 'Excel.Application
    Dim xlRng As Object 'Excel.Range
    Dim xlwkbk As Object 'Excel.Workbook
    Dim xlwksht As Object 'Excel.Worksheet
     
    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application
     
    Dim olExp As Outlook.Explorer
    Set olExp = olApp.ActiveExplorer
     
    Dim olFolder As Outlook.MAPIFolder
    Set olFolder = olExp.CurrentFolder
        
    'Open Excel
    Set xlApp = GetExcelApp
    xlApp.Visible = True
    If xlApp Is Nothing Then GoTo ExitProc
     
    Set xlwkbk = xlApp.Workbooks.Add
    Set xlwksht = xlwkbk.Sheets(1)
    Set xlRng = xlwksht.Range("A1")
    xlRng.value = "Was Read email addresses"
     
    'Set count of email objects
    Dim count As Long
    count = olFolder.Items.count
     
    'counter for excel sheet
    Dim i As Long
    i = 1
     
    'counter for emails
    x = 1
     
    'Read the items in the folder
    For Each olItem In olFolder.Items
        Select Case olItem.Class
            Case olMail, olReport
                If InStr(1, olItem.Subject, "not read", vbTextCompare) > 0 Then
                    stremBody = olItem.Body
                    stremSubject = olItem.Subject
                    stremSender = SMTP2007(olItem)
                    xlwksht.Cells(i, 1) = stremSender
                    x = x + 1
                    i = i + 1
                End If
        End Select
        xlApp.StatusBar = x & " of " & count & " emails completed"
    Next olItem
     
    xlApp.ScreenUpdating = True
     
ExitProc:
    Set xlRng = Nothing
    Set xlwksht = Nothing
    Set xlwkbk = Nothing
    Set xlApp = Nothing
    Set emItm = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub
 
Function GetExcelApp() As Object
    ' always create new instance
    On Error Resume Next
    Set GetExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0
End Function
 
Function SMTP2007(olkMsg As Object) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

    • Hi David,
      If you need some reports (read/not read) for testing, i’ll send you, give me your email address.
      Thanks.

    • Hi, Phuong.

      Please try this version.

      Sub Testing()
    'Extract_Not_Read_Report Use for Outlook
    'read mails in Inbox folfer
    
    Dim olItem As Object
    
    Dim stremBody As String
    Dim stremSubject As String
    Dim stremSender As String
    
    Dim x As Long
    Dim xlApp As Object 'Excel.Application
    Dim xlRng As Object 'Excel.Range
    Dim xlwkbk As Object 'Excel.Workbook
    Dim xlwksht As Object 'Excel.Worksheet
    
    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application
    
    Dim olExp As Outlook.Explorer
    Set olExp = olApp.ActiveExplorer
    
    Dim olFolder As Outlook.MAPIFolder
    Set olFolder = olExp.CurrentFolder
       
    'Open Excel
    Set xlApp = GetExcelApp
    xlApp.Visible = True
    If xlApp Is Nothing Then GoTo ExitProc
    
    Set xlwkbk = xlApp.Workbooks.Add
    Set xlwksht = xlwkbk.Sheets(1)
    Set xlRng = xlwksht.Range("A1")
    xlRng.value = "Was Read email addresses"
    
    'Set count of email objects
    Dim count As Long
    count = olFolder.Items.count
    
    'counter for excel sheet
    Dim i As Long
    i = 2
    
    'counter for emails
    x = 0
    
    'Read the items in the folder
    For Each olItem In olFolder.Items
        Select Case olItem.Class
            Case olMail, olReport
                If InStr(1, olItem.Subject, "not read", vbTextCompare) > 0 Then
                    stremBody = olItem.Body
                    stremSubject = olItem.Subject
                    stremSender = SMTP2007(olItem)
                    xlwksht.Cells(i, 1) = stremSender
                    x = x + 1
                End If
        End Select
        xlApp.StatusBar = x & " of " & count & " emails completed"
    Next olItem
    
    xlApp.ScreenUpdating = True
    
ExitProc:
    Set xlRng = Nothing
    Set xlwksht = Nothing
    Set xlwkbk = Nothing
    Set xlApp = Nothing
    Set emItm = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Function GetExcelApp() As Object
    ' always create new instance
    On Error Resume Next
    Set GetExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0
End Function

Function SMTP2007(olkMsg As Object) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

    • Hi David,
      Great! Now, your code run well after i insert i = i + 1 into row 60.
      For this topic i had searched for very long time but could not found and solved.
      Please receive from me very very big thanks.

      However, when i change conditional string “not read” = “failure” mean mail items that sent fail, extract = nothing. So I think it does not work with mail items. I hop you willing to help me checking it.

      While, i think you could cleanup this comment page, and post full code for sharing to others. Here is full code:

      Sub Extract_Not_Read_Report()
    'Extract_Not_Read_Report Use for Outlook
    'read mails in Inbox folfer
    
    Dim olItem As Object
    
    Dim stremBody As String
    Dim stremSubject As String
    Dim stremSender As String
    
    Dim x As Long
    Dim xlApp As Object 'Excel.Application
    Dim xlRng As Object 'Excel.Range
    Dim xlwkbk As Object 'Excel.Workbook
    Dim xlwksht As Object 'Excel.Worksheet
    
    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application
    
    Dim olExp As Outlook.Explorer
    Set olExp = olApp.ActiveExplorer
    
    Dim olFolder As Outlook.MAPIFolder
    Set olFolder = olExp.CurrentFolder
       
    'Open Excel
    Set xlApp = GetExcelApp
    xlApp.Visible = True
    If xlApp Is Nothing Then GoTo ExitProc
    
    Set xlwkbk = xlApp.Workbooks.Add
    Set xlwksht = xlwkbk.Sheets(1)
    Set xlRng = xlwksht.Range("A1")
    xlRng.Value = "Was Read email addresses"
    
    'Set count of email objects
    Dim count As Long
    count = olFolder.Items.count
    
    'counter for excel sheet
    Dim i As Long
    i = 2
    
    'counter for emails
    x = 0
    
    'Read the items in the folder
    For Each olItem In olFolder.Items
        Select Case olItem.Class
            Case olMail, olReport
                If InStr(1, olItem.Subject, "not read", vbTextCompare) > 0 Then
                    stremBody = olItem.Body
                    stremSubject = olItem.Subject
                    stremSender = SMTP2007(olItem)
                    xlwksht.Cells(i, 1) = stremSender
                    x = x + 1
                End If
        End Select
        xlApp.StatusBar = x & " of " & count & " emails completed"
        i = i + 1
    Next olItem
    
    
    xlApp.ScreenUpdating = True
    
ExitProc:
    Set xlRng = Nothing
    Set xlwksht = Nothing
    Set xlwkbk = Nothing
    Set xlApp = Nothing
    Set emItm = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Function GetExcelApp() As Object
    ' always create new instance
    On Error Resume Next
    Set GetExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0
End Function

Function SMTP2007(olkMsg As Object) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

    • Hi David,
      The word “failure” appear in the subject line. Extract = nothing.
      And at row : xlApp.StatusBar = x & ” of ” & count & ” emails completed”. Not run complete. This mean while done, in status bar : x < count (ie: 4 of 397).
      Thanks.

    • Hi, Phuong.

      I apologize for taking so long to respond to your last post.

      The “i = i + 1” should go immediately after line 56. If placed at line 60, then “i” is going to increment for every item in the mailbox, even those that aren’t mail or report items. That will leave blank lines in the spreadsheet.

      If I understand correctly, you’re saying that after changing line 51 from “not read” to “failure” the code is not detecting the items with “failure” in the subject line. The only way the code could fail to detect “failure” in the subject line is if the word is capitalized (i.e. “Failure”) or in all caps (i.e. “FAILURE”). We can make the comparison case-insensitive by changing line 51 to 

      If InStr(1, LCase(olItem.Subject), "failure", vbTextCompare) > 0 Then

      This will force the subject line to all lower-case for the comparison.

    • Hi Dave,

      Brilliant. This is what I have kinda been looking for. Is my thinking right that that included in this will be a message id? If so does the message ID stay the same with replies (so it puts a new ID on for all new emails and that ID stays the same all the time with the email?).

      What I am trying to do is import all my emails to a spreadsheet and then put an ID against each one, if its a reply use the same id, I was hoping I could maybe use the message id.

      If so I a a bit unsure how to add this code into what I have created. Please see my code bellow:

      Option Explicit
Const fPath As String = "C:\Users\neo_s_000\Desktop\Emails\" 'The path to save the messages
Const sfName As String = "C:\Users\neo_s_000\Desktop\Message Log.xlsx"

Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
    If FileExists(sfName) Then
        Set xlBook = Workbooks.Open(sfName)
        Set xlSheet = xlBook.Sheets(1)
    Else
        Set xlBook = Workbooks.Add
        Set xlSheet = xlBook.Sheets(1)
        With xlSheet
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Date"
            '.Cells(1, 4) = "Size"
            .Cells(1, 5) = "EmailID"
            .Cells(1, 6) = "Body"
        End With
        xlBook.SaveAs sfName
    End If
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err  0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    With xlSheet
        .Cells(1, 1) = "Sender"
        .Cells(1, 2) = "Subject"
        .Cells(1, 3) = "Date"
        '.Cells(1, 4) = "Size"
        .Cells(1, 5) = "EmailID"
        .Cells(1, 6) = "Body"
        CreateFolders fPath
        Set olNS = olApp.GetNamespace("MAPI")
        olNS.Logon
        Set olFolder = olNS.PickFolder
        For Each olItem In olFolder.Items
            NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            If olItem.Class = 43 Then
                .Cells(NextRow, 1) = olItem.Sender
                .Cells(NextRow, 2) = olItem.Subject
                .Cells(NextRow, 3) = olItem.SentOn
                '.Cells(NextRow, 4) =
                .Cells(NextRow, 5) = SaveMessage(olItem)
                .Cells(NextRow, 6) = olItem.Body
            End If
        Next olItem
        MsgBox "Outlook Mails Extracted to Excel"
    End With
    xlBook.Close SaveChanges:=True
lbl_Exit:
    Set olApp = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub

Function SaveMessage(olItem As Object) As String
Dim Fname As String
    Fname = Format(olItem.ReceivedTime, "yyyymmdd") &amp; Chr(32) &amp; _
            Format(olItem.ReceivedTime, "HH.MM") &amp; Chr(32) &amp; olItem.sendername &amp; " - " &amp; olItem.Subject
    Fname = Replace(Fname, Chr(58) &amp; Chr(41), "")
    Fname = Replace(Fname, Chr(58) &amp; Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")
    SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath &amp; strFileName &amp; ".msg") = True
        strFileName = Left(strFileName, lngName) &amp; "(" &amp; lngF &amp; ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath &amp; strFileName &amp; ".msg"
    SaveUnique = strPath &amp; strFileName &amp; ".msg"
lbl_Exit:
    Exit Function
End Function

Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) &amp; "\"
    For iPath = 1 To UBound(vPath)
        strPath = strPath &amp; vPath(iPath) &amp; "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next iPath
End Sub

Private Function FolderExists(ByVal PathName As String) As Boolean
   Dim nAttr As Long
   On Error GoTo NoFolder
   nAttr = GetAttr(PathName)
   If (nAttr And vbDirectory) = vbDirectory Then
      FolderExists = True
   End If
NoFolder:
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

    • Hi, Richard.

      Thanks!

      All messages have a property called ConversationIndex. All the messages in a given conversation have a common root ConversationIndex value. Each message in the conversation adds a value to the ConversationIndex of its parent. For example, assume you create and send a message. Outlook assigns that message a ConversationIndex. For the sake of brevity I’m going to use three character values for each element of the ConversationIndex. Let’s say that Outlooks set the root value to ABC. The recipient replies to your message and Outlook adds 123 to the ConversationIndex. You reply and again Outlook adds to the ConversationIndex. Let’s say it adds DEF. The ConversationIndex is now ABC123DEF. Note that all the messages have the root value ABC. You could find all the messages in the conversation by searching all messages in your mailbox for that root value. You can also find a given message’s parent by stripping off the last value added to the ConversationIndex. The parent of ABC123DEF is ABC123 (ABC123DEF – DEF). This Microsoft page explains how the ConversationIndex is constructed.

    • Hello,
      I need to extract the Internet Header from a msg file.
      I’m using: MS Outlook 2007, Excel 2007(Excel inside VB 6.5)
      Unfortunately the presented codes are not working for me.

      Sub GettingFile()
    Dim SelectedFile As String
   
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show = -1 Then
            SelectedFile = .SelectedItems(1)
           
            Dim wb As Workbook
            Dim ws As Worksheet
            Set wb = ThisWorkbook
            Set ws = wb.Worksheets("RITC")
           
            Dim OutlookApp As Object
            Dim MItem As Object
            Set OutlookApp = CreateObject("Outlook.Application")
            Set MItem = OutlookApp.CreateItemFromTemplate(SelectedFile)
   
            ws.Cells(6, 2) = MItem.Subject
            ws.Cells(4, 2) = MItem.Body

            ws.Cells(5, 2) = GetInetHeaders(MItem) &lt;-- !!!!!!!!!!!!!!!! DOESN'T WORK(Function not defined)

            With New FileSystemObject
                If .FileExists(SelectedFile) Then
                    .DeleteFile SelectedFile
                End If
            End With         
           
         
        Else
       
        End If
   
    End With
     
End Sub

      Can someone please help me?

    • Hi, Alin.

      I see two problems. First, based on the error message you must not have added the code from my post to your VB project. You have to do that before this is going to work. Second, you’re trying to get the internet headers of a message that’s not been sent. That’s not going to work. This is only going to work with sent/received messages.

  3. Hi David,

    As a sysadmin/Exchange admin, I know how to go to the Rules in Outlook 2013 and select the “run a script” option, but I have no clue about how I get your code above (which I’ve copied and pasted into a Notepad txt file for safekeeping) to show up as a script that I can choose when I click on the little “script” link that the rule offers. In other words… uh … now what? Got the code? Check. Know how to create a rule and choose “run a script”? Check. Know how to make the two meet each other? Nope.

    Reply

    • Hi, Gabe.

      That script isn’t intended to run from a rule. It returns the internet header as a text string and is intended to be called from another script. I can tell you how to hook it up to a rule, but it won’t do anything when the rule calls it. What is it that you want to accomplish? Once I know that, then I’ll be in a better position to suggest a solution.

    • yikes … I forgot I was logged into my other account… and I can’t find your email address, so I’m asking you here in the comments section… Can you delete my follow-up comment that was posted from soosiekue? I will resubmit it as Gabe. Thanks.

    • I apologize for my confusion, which stemmed from reading (too quickly) your comment posted on November 9, 2010 @ 6:06am, which says “The macro in my last comment is meant to be run via a rule.” My bad.

      Here’s my goal: I want to extract/capture/export (whatever the term is) just the sender’s email address. This is for email list cleanup. People send an email to our “unsubscribe” mailbox, and I have to take the sender’s email address and use it to search for that address on another system. Currently, I have to open each message to get the sender’s email address. I’d prefer to just get the sender’s email address copied into a csv or excel file automatically, but have no clue how to achieve that, so I’ll settle for at least not having to manually open each incoming message one by one to get the sender’s email address. I wish I knew more than simple batch file scripting!! I’m lucky that I even know how to spell “VBA”. geesh

      update: I have taken a look at your “Exporting Outlook Messages to Excel” post, and was blown away to witness Visual Basic for Applications actually OPEN on my computer when I pressed ALT+F11 (per your excellent instructions!) just now, because I was sure that I didn’t have it on my computer and therefore assumed I wouldn’t be able to apply the steps outlined in that post. I haven’t gotten past that point yet, but if you think it’ll meet my needs, I’ll take my instructions from it (but really, I have ZERO background for this, and I’m assuming that I will need to previously have downloaded libraries and other files and an abacus or god-knows-what before I could do any of that stuff in that post).

      Anyway, thanks for your awesome work here in this blog. You clearly care about your readers.

    • Gabe,

      So long as you have Office on your computer, then your computer should be able to do everything in that post without any additional libraries, etc. There’s a surprising amount of automation capability built into Office/Windows.

      As for exporting the sender’s address, that’s simple. But, you need to look at the code in the “Exporting Outlook Messages to Excel” post, not this post. This post won’t get you what you need. To export the addresses, just modify the code from the initial “Exporting Outlook Messages to Excel” post. All you need to do is remove the lines that write the subject and date and you’ll be left with the addresses. If you want to take this a step further, then I can whip up a solution that will automatically save the email address of everyone who sends you a message to a file. A database (Access) would be best, but I can write the addresses to a spreadsheet or text file if that’s what you’d prefer.

    • When I try to run the Macro, it says macros are disabled. I go to the Tools menu, Macros… but there is no Security option anywhere. This is on Windows 8.1, running Office 2013.

    • Found it! Went to Outlook, File, Options, Trust Center > clicked on Trust Center Settings… button inside Trust Center, then Macro Settings, and chose “Enable all macros (not recommended; potentially dangerous code can run)

      clicked OK, then OK again

      Went back to VBA editor, and clicked Run on that open Module, and bingo!, a box popped up asking for a file name.

      You sir, to quote another commenter, are a genius. Thank you!!!!

  4. Hello,

    When trying to pull data via a web query (i.e. Querytable) in Excel I get an error saying “Unable to open https://… Cannot download the information you requested.” .

    This is happening because the page has a “Pragma: no-cache” header to avoid saving the web page to the Internet Explorer cache. In order for the download operation to work, the file has to be saved to IE. Not allowing the file to be cached causes the error. The site is secured (https). The suggested solution is to:

    1. Edit the web page from where you are pulling your data and remove the no-cache header. You would be looking for a meta tag like the following:

    2. You can direct the client computer to set the Internet Explorer option to bypass the no-cache check for SSL sites (remember the https:// in the sample URL above). To do this, go to START and in the RUN line type REGEDIT. In the registry navigate to HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings. Right click Internet Settings and left click New > DWORD Value (32-bit) and name the new value “BypassSSLNoCacheCheck” without the quotes. Double click this value and give it a value of 1.

    3. To work around this problem, use a hypertext reference (HREF) to load the document. Note:This workaround works only if the server uses the “cache-control:no-store” header.

    I would like to know if I use suggested solution #1 in my vba code. I want to change the http response header in the vba code to:
    Pragma: no-cache
    Cache-Control: no-cache

    If that is possilble, where would I put the code?
    my code below:

    Worksheets(“QryHold”).Activate
    Worksheets(“QryHold”).Range(“A1”).Select
    With Selection.QueryTable
    .Connection = _
    “URL;https://pts-2.usps.gov/pts2-web/tcIntranetTrackingNumResponse?label=” & label & “&status=Live&mailingDate=&userSearchTypeChoice=Extensive”
    ‘Destination:=Worksheets(“QryHold”).range(“A1)
    .Name = _
    “tcIntranetTrackingNumResponse?label=” & label & “&status=Live&mailingDate=&userSearchTypeChoice=Extensive”
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingNone
    .WebTables = “4,5,6,7,8,9,””extraservicedetails””,12,””events”””
    .WebPreFormattedTextToColumns = False
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False

    End With

    Thank you for your help, I really need it.
    smsemail

    Reply

    • Hi, smsemail.

      I’ll start by saying that I am NOT an Excel expert. I can do some things in Excel, but it’s not my strong suit. That said, I don’t believe solution #1 will work from the local computer. I believe solution #1 only works if you own the web page and can make that change on the web server. Making the change after the page is loaded in the browser is pointless. I did do a little research and found this page at MrExcel.com which describes a problem similar, though not identical, to yours. The user discovered that the page in question had a Flash ad that was causing the problem. The solution the user came up with was to download the page to the local computer, remove the Flash ad, then point the webquery at the local page. I don’t know if this will work for you, but you could try downloading the page and then pointing the webquery at the local page.

    • Hi David,

      Thank you so much for your help. I truly appreciate it. I am going to try the solution of downloading the web page to local desktop then using the WebQuery to import the data to Excel.

      Thank you for pointing me to that solution. I will let you know how it worked.

      Thank you for your blog….I know it has helped many!

      smsemail

  5. Hi David,

    So how would you modify the code to export the message headers to a file, say on the C Drive? I’m using Outlook 2010 by the way.

    Thanks!

    Reply

  6. Hi David,

    What I would like to do is add a date stamp into the internet headers that I will eventually be able to extract in excel. I monitor a specific email folder where incoming emails are tasks. When a task is complete, it is moved to a different folder. I want to add the current date stamp in the internet header and eventually pull that date stamp out of the int. header and subtract the received email date to receive the turn time of the task.

    I have separated the scripts so that the process of moving the email to a different folder (and, currently, adding the date stamp to the subject, however, I have realized I don’t want to edit the subject) and exporting the emails from outlook are separate.

    My main question is how would I be able to add the date stamp to the beginning of the email’s internet header so I can extract the data later in excel.

    Your support is very much appreciated!!

    Kind regards,

    Brennan

    Reply

    • Hi, Brennan.

      When you say “… current date stamp …” do you mean the date you completed the task? If so, then there are simpler ways to do this than adding to the internet header. First, depending on which version of Outlook you have, you can flag an email as a task. When you mark that email complete, Outlook stores the date in a property called TaskCompleteDate. You can extract that value in Excel. Second, you can store the date you completed the task in a custom property. That too can be extracted in Excel. Both are simpler than storing the information in the internet header. The only real compelling reason to use the internet header is if you need to send the message on to someone else, someone who doesn’t have Outlook, and want to pass the date completed along with the message.

  7. David,
    This is a very useful script! What I am trying to do is run a script against a folder of emails searching the PR_TRANSPORT_MESSAGE_HEADERS for a string and when it is found, copy the email to a particular folder. Andy suggestions

    Reply

    • Hi, Andy.

      Thanks! I’m glad you like it.

      That’s doable. When you say “copy the email to a particular folder” do you mean an Outlook folder or a folder in the file system?

    • Thanks for the quick reply, David.

      Is it possible to have a script set the email as a task and complete it at the same time… I am using Outlook 2010? This macro will be used by an employee and I am trying to make it as automated as possible to eliminate human error.

      This sounds like the optimal solution as it would greatly minimize the script and the datapull of all emails in the specific folder would not have to extract the entire message or internet header.

      Brennan

    • Brennan,

      Sure, that’s possible but it’s not really necessary. You could also mark an item as a task now using Outlook’s interface then mark it complete sometime later (also through Outlook’s interface). For example, mark an item as due in two days, then mark it as complete later once you’ve finished with it. You don’t need a script to do either. If you want to mark an item as a task and complete it at the same time, then again you can do that through Outlook’s interface. Just right-click the flag icon next to the item and select “Mark Complete”. You can also select multiple items and use the same sequence of actions to mark them all at the same time.

    • David,
      My issue is more of a training issue as this macro will be used by multiple people who may not be strong with Outlook or they are smart enough to trick the “system”. My role is to track performance of these tasks and I am trying to get a turn time for each task. My goal is to only add 1 step for each employee (which would be to click a shortcut button in outlook after the task is complete) instead of 3 or 4 clicks per task. If I were to ask everyone to add the to-do flag and then complete it, people would be completing tasks before they were done which would shorten the turn time and ultimately make them look fast than what they really are.

      I don’t know how to add a script box here, but this is the code I currently have.. I am getting stuck at setting the flag status to complete:

      Sub ConvertSelMailtoTaskThenCompleted()
      Dim oTask As Outlook.TaskItem
      Dim oMail As Outlook.MailItem

      Set oTask = Application.CreateItem(olTaskItem)

      For Each oMail In Application.ActiveExplorer.Selection

      With oTask
      .Subject = oMail.Subject
      .startDate = oMail.ReceivedTime
      .Body = oMail.Body
      .Save
      End With

      With oMail
      .FlagRequest = olFlagComplete
      End With

      Next
      Set oTask = Nothing
      Set oMail = Nothing
      End Sub

    • Brennan,

      Ok. For whatever it’s worth, they’ll be able to “trick the system” just as easily with a macro. They can run the macro and mark an item as complete immediately before they actually do any work, making it appear as if they finished sooner than they did.

      Unless I’ve misunderstood your initial explanation of what you want, you don’t need to create a task for this. You can do it all with the message itself. This macro will mark the message as a task and then mark it complete immediately. You can add a button to the Quick Access Toolbar (QAT) so the users can run it with a single click. Let me know if you need instructions on how to do that.

      Sub MarkItemAsCompletedTask()
    Dim olkMsg As Outlook.MailItem
    For Each olkMsg In Application.ActiveExplorer.Selection
        With olkMsg
            .TaskDueDate = Date
            .FlagStatus = olFlagComplete
            .TaskCompletedDate = Date
            .Save
        End With
    Next
    Set olkMsg = Nothing
End Sub

    • This is perfect for what I am looking for. I know the process sounds a little strange, just trying to keep everything as hands off as possible for the poeple who will actually run the process.. except for the button in the QAT. I am new to Outlook scripts, you insight is very much appreciated.

      Thanks David!

  8. Hi David,

    We have an email system which detects SPAM and allows the user to influence the detection by calling URL’s which are hidden in the headers of the mail, e.g.

    X-Antispam-Training-Nonspam: https://www.mf.surf.net/canit/b.php?i=03M5nR8mn&m=cf5dc21a19b1&t=20140523&c=n
    X-Antispam-Training-Spam: https://www.mf.surf.net/canit/b.php?i=03M5nR8mn&m=cf5dc21a19b1&t=20140523&c=s

    Would it be possible to write a macro with your function and couple them to quickstep buttons, eg. “Mark SPAM” would open a browser with the 2nd link and
    “Mark NonSpam” the first?

    thanks in advance,
    Ewald…

    Reply

    • Hi, Ewald.

      I think I can do that. Could you provide me a sample message, one that contains these headers, I can test against?

    • oops, i completely missed your rapid reply.
      It would be great if this could be done and
      i would gladly send you a sample message.
      Do you want me to drop it in a comment here
      or shall i send it by mail?

      best regards,
      Ewald…

    • Ewald,

      This should do it. You can create two QAT buttons, one that points to MarkAsNonSpam and one that points to MarkAsSpam. 

      Sub MarkAsNonSpam()
    Const HEADER_TEXT = "X-Antispam-Training-Nonspam: "
    Dim strHdr As String, strURL As String, objIE As Object
    strHdr = GetInetHeaders(Application.ActiveExplorer.Selection(1))
    strURL = FindString(strHdr, HEADER_TEXT & "(.+)\b")
    If strURL = "Not found" Then
        MsgBox "Did not find the nonspam URL in the header.", vbInformation + vbOKOnly, "Mark As Non-spam"
    Else
        strURL = Replace(strURL, HEADER_TEXT, "")
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate2 strURL
        objIE.Visible = True
    End If
    Set objIE = Nothing
    Debug.Print strURL
End Sub

Sub MarkAsSpam()
    Const HEADER_TEXT = "X-Antispam-Training-Spam: "
    Dim strHdr As String, strURL As String, objIE As Object
    strHdr = GetInetHeaders(Application.ActiveExplorer.Selection(1))
    strURL = FindString(strHdr, HEADER_TEXT & "(.+)\b")
    If strURL = "Not found" Then
        MsgBox "Did not find the spam URL in the header.", vbInformation + vbOKOnly, "Mark As Spam"
    Else
        strURL = Replace(strURL, HEADER_TEXT, "")
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate2 strURL
        objIE.Visible = True
    End If
    Set objIE = Nothing
    Debug.Print strURL
End Sub

Private 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

Function FindString(strText As String, strFind As String) As String
    Dim objRegEx As Object, colMatches As Object, objMatch As Object
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = False
        .Global = True
        .Pattern = strFind
        Set colMatches = .Execute(strText)
    End With
    If colMatches.Count > 0 Then
        Set objMatch = colMatches.Item(0)
        FindString = objMatch.Value
    Else
        FindString = "Not found"
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
    Set objMatch = Nothing
End Function

    • Hi David,

      The macro’s work great! I have added two buttons in the Quick Access Toolbar
      and they pop-up a browser which has marked the message as Spam of Non-Spam.
      This is a joyful day 🙂

      One last question (isn’t there allways one 😉
      is it also possible to move the message in that subroutine?
      So MarkAsSpam calls the URL
      but also moves the message from the Inbox => Spam
      and MarkAsNonSpam moves from Spam => Inbox?

      TIA,
      Ewald….

    • Hi, Ewald.

      Yes, that’s possible. I’ve modified the code to do this. Replace the MarkAsNonSpam and MarkAsSpam subroutines with the versions below. Please leave that rest of the code as is.

      Sub MarkAsNonSpam()
    Const HEADER_TEXT = "X-Antispam-Training-Nonspam: "
    Dim strHdr As String, strURL As String, objIE As Object, olkItm As Object
    Set olkItm = Application.ActiveExplorer.Selection(1)
    strHdr = GetInetHeaders(olkItm)
    strURL = FindString(strHdr, HEADER_TEXT & "(.+)\b")
    If strURL = "Not found" Then
        MsgBox "Did not find the nonspam URL in the header.", vbInformation + vbOKOnly, "Mark As Non-spam"
    Else
        strURL = Replace(strURL, HEADER_TEXT, "")
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate2 strURL
        objIE.Visible = True
        olkItm.Move Session.GetDefaultFolder(olFolderInbox)
    End If
    Set objIE = Nothing
End Sub

Sub MarkAsSpam()
    Const HEADER_TEXT = "X-Antispam-Training-Spam: "
    Dim strHdr As String, strURL As String, objIE As Object, olkItm As Object
    Set olkItm = Application.ActiveExplorer.Selection(1)
    strHdr = GetInetHeaders(olkItm)
    strURL = FindString(strHdr, HEADER_TEXT & "(.+)\b")
    If strURL = "Not found" Then
        MsgBox "Did not find the spam URL in the header.", vbInformation + vbOKOnly, "Mark As Spam"
    Else
        strURL = Replace(strURL, HEADER_TEXT, "")
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate2 strURL
        objIE.Visible = True
        olkItm.Move Session.GetDefaultFolder(olFolderJunk)
    End If
    Set objIE = Nothing
End Sub

  9. Hi David, thanks for this. The function GetInetHeaders is useful in extracting the header, which is a part of my current project. Now, can you save this as an xml file to a shared drive? Is there a quick way to do this, so it looks like:

    <….

    Reply

    • Hi, Mark.

      You’re welcome. The XML you included in the post didn’t come through. Can you post a screenshot of the format or email it to me?

    • Hi David, just FYI – I solved it with:
      outFile = DestFolder & “\” & “Mailheader.xml”
      Set objFile = fs.CreateTextFile(outFile, True)
      objFile.Write (” XML elements” & Cstr (ObjMessage.SenderName) & “rest of the XML elements”……. & objMessage.To, objMessage.ReceivedTime etc. in between..)”
      objFile.Close

  10. Hi,

    How to edit internet header of received mails and mail id’s in headers in outlook 2007.

    Can any one help and guide please.

    Thanks

    Reply

  12. David,

    Good day, I think this blog is awesome. I know this an old topic, but I was wondering if it is possible for the macro to save all the email headers in a PST file — naming each text file by their entryid or just something unque like header0000001, header0000002, etc.

    Reply

  14. Pingback: Rapid Vieweing of Internet Headers « TechnicLee

  16. hrm… I’m still missing something. I run both of these in VBA and I get a box that pops up asking me to create a new macro. Shouldn’t this code BE the macro? I’m using the following references:
    Visual Basic for Applications
    Microsoft Outlook 14.0 Obj Library
    OLE Automation
    Microsoft Office 14.0 Obj Library
    Microsoft Forms 2.0 Obj Library

    Sorry if I’m not following you completely. This scripting thing is still very new to me but is also pretty exciting stuff!

    Reply

    • The macro in my last comment is meant to be run via a rule. If you want to run it manually, then we need to modify it a bit. Something like this.

      Sub ForwardHeader()
    Dim olkItm As Outlook.MailItem, olkFwd As Outlook.MailItem
    For Each olkItm In Application.ActiveExplorer.Selection
        strHeader = GetInetHeaders(olkItm)
        Set olkFwd = Application.CreateItem(olMailItem)
        With olkFwd
            .BodyFormat = olFormatPlain
            .To = "leif.hurst@trustsig.com"
            .Subject = "Your Subject Goes Here"
            .Body = strHeader
            .Send
        End With
    Next
    Set olkFwd = Nothing
End Sub

  17. You’re script is perfect… I’m struggling with the next part though. I guess that’s what happens when you’re trying to merge 2-3 scripts together.

    I’m trying to take this string and get the script to output it to a new email body with my address, etc.

    Reply

    • That’s a start. The other part should be pretty easy. Something like this should do it. You’ll pass this routine an email item.

      Sub ForwardHeader(Item As Outlook.MailItem)
    Dim olkFwd As Outlook.MailItem
    strHeader = GetInetHeaders(Item)
    Set olkFwd = Application.CreateItem(olMailItem)
    With olkFwd
        .BodyFormat = olFormatPlain
        .To = "leif.hurst@trustsig.com"
        .Subject = "Your Subject Goes Here"
        .Body = strHeader
        .Send
    End With
    Set olkFwd = Nothing
End Sub

  18. Thank you so much for posting this! Now I’ll hack away at it to get it to paste into a new mail message.

    I’m trying to extract a line called x-note whtlist so I can get the true sender of spam. Turn this into a button that then emails me, the admin, so I can see why it slipped through our filters.

    Reply

    • You’re welcome, Leif. Once you have the headers you can parse them either via RegEx or by splitting them into an array of lines via the SPLIT function. Find the line with x-note and extract it. Depending on how your existing code works you might be able to substitute this function for the CDO code you were using to get the header and everything else will work just as it did before.

    • The macro in my last comment is meant to be run via a rule. If you want to run it manually, then we need to modify it a bit. Something like this.

      Sub ForwardHeader()
    Dim olkItm As Outlook.MailItem, olkFwd As Outlook.MailItem
    For Each olkItm In Application.ActiveExplorer.Selection
        strHeader = GetInetHeaders(olkItm)
        Set olkFwd = Application.CreateItem(olMailItem)
        With olkFwd
            .BodyFormat = olFormatPlain
            .To = "leif.hurst@trustsig.com"
            .Subject = "Your Subject Goes Here"
            .Body = strHeader
            .Send
        End With
    Next
    Set olkFwd = Nothing
End Sub

Leave a comment