Exporting Outlook Messages to Excel


I’m writing this post primarily for Sen who in a comment to another post asked

How do i Export e-mail messages with the subject, received date & time from Outlook to Excel with the sender address?

The simplest way to carry out this is to use Outlook’s built-in export capability. Using it you can export to a .csv (comma separated values) file which you then open with Excel. However, there are a couple of drawbacks to using export. Export doesn’t allow you to pick specific messages to export so you’ll have to export an entire folder at a time. It also doesn’t allow you to limit the export to certain fields. Instead it will export everything and you’ll have to delete the columns you don’t want.

A better, but more complicated, approach is to use a macro to do the export. With a macro you can select the messages you want, export only the fields you want, and it can write directly to Excel. The code for doing this is both simple and straightforward. It creates a spreadsheet, loops though the selected messages writing the fields you want to that spreadsheet, then saves and closes the spreadsheet. This solution should work in Outlook 2007 and later.

Adding the code to Outlook.

  1. Start Outlook
  2. Press ALT+F11 to open the 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. Click the diskette icon on the toolbar to save the changes
  8. Close the VB Editor
Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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
 

Using the Code.

  1. With Outlook open select a folder that contains emails.
  2. Run the macro.
  3. When prompted enter a filename to save the export to. You can cancel the export by not entering anything.
  4. The macro will display a dialog-box when it’s finished. The dialog-box includes a count of the number of messages exported.

Notes.

  • This code can easily be modified to export a different set of fields. To do that, change the headings written to the spreadsheet (lines 15-17) and the message fields (lines 25-27).
  • If you don’t want the macro to prompt for a filename each time, then you can change line 7 to strFilename = “Path_and_File_Name”

Revisions.

1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48 49  

This revision is for Sen who asked for a way to use the code to export a set list of folders each day without having to manually open and export each one individually. To accomplish that I’ve added a controller which calls the export routine for each folder in Sen’s list. All Sen needs to do is edit the ExportController subroutine by adding a line for each folder he wants to export. Each call will pass the filename and path to the spreadsheet the code will export the messages to and the path to the source Outlook folder it will export from.

In case you aren’t familiar with Outlook folder paths, here’s an explanation of how to figure them out. A folder path in Outlook is essentially the same as a folder path in the file system. The one difference being that Outlook folder paths do not include a drive letter. The path to a folder is a list of all the folders from the root to the target folder with each folder name separated from the preceding folder name by a backslash (i.e. \). Consider the following folder structure:

Mailbox - Doe, John
    - Calendar
    - Inbox
    - Tasks
Personal Folders
    + Marketing
        + Proposals
        + Reviews
    + Projects
        + Project 1
        + Project 2

The path to “Inbox” is “Mailbox – Doe, John\Inbox”.
The path to “Reviews” is “Personal Folders\Marketing\Reviews”.
The path to “Project 1″ is “Personal Folders\Projects\Project 1″.

Const MACRO_NAME = "Export Messages to Excel (Rev 1)"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
    ExportMessagesToExcel "C:\Folder2.xlsx", "Personal Folders\Folder2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
    Dim olkMsg As Object, _
        olkFld As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkFld = OpenOutlookFolder(strFolderPath)
            If TypeName(olkFld) <> "Nothing" Then
                intVersion = GetOutlookVersion()
                Set excApp = CreateObject("Excel.Application")
                Set excWkb = excApp.Workbooks.Add()
                Set excWks = excWkb.ActiveSheet
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "Received"
                    .Cells(1, 3) = "Sender"
                End With
                intRow = 2
                'Write messages to spreadsheet
                For Each olkMsg In olkFld.Items
                    'Only export messages, not receipts or appointment requests, etc.
                    If olkMsg.Class = olMail Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.Subject
                        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                        intRow = intRow + 1
                    End If
                Next
                Set olkMsg = Nothing
                excWkb.SaveAs strFilename
                excWkb.Close
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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
 

This revision is for Canny who asked for a means of exporting to an existing spreadsheet instead of creating a new one each time, and for the exported items to be linked back to the originals in Outlook. This version implements both of these features. The first time Canny runs the export the code will create the spreadsheet if it doesn’t exist. On each subsequent export it will either overwrite the first sheet in the workbook or add a sheet. The behavior is controlled by changing the value of EXPORT_NEWSHEET (True = add a new sheet each time, False = overwrite the first sheet in the book each time).

If the hyperlinks from the items in the spreadsheet to the original items in Outlook don’t work, then it’s because you don’t have the Outlook protocol handler installed. Outlook 2007 and later doesn’t automatically install the Outlook protocol handler (which allows linking to Outlook items and folders) like earlier versions of Outlook did. You have to edit the registry and add an entry to enable it. Here’s a link to a page with details and a .reg file you can download to speed up the process. Pay attention to the instructions on the page about editing the .reg file. Also, if you have Outlook 2010 you’ll have to make another edit, changing the references to Office12 to Office14.

'On the next line change the value to True if you want each export to go on a new sheet.
Const EXPORT_NEWSHEET = False
Const MACRO_NAME = "Export Messages to Excel (Rev 2)"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
    ExportMessagesToExcel "C:\Folder2.xlsx", "Personal Folders\Folder2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
    Dim olkMsg As Object, _
        olkFld As Outlook.MAPIFolder, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVer As Integer
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkFld = OpenOutlookFolder(strFolderPath)
            If TypeName(olkFld) <> "Nothing" Then
                intVer = GetOutlookVersion()
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set excApp = CreateObject("Excel.Application")
                If objFSO.FileExists(strFilename) Then
                    Set excWkb = excApp.Workbooks.Open(strFilename)
                    If EXPORT_NEWSHEET Then
                        Set excWks = excWkb.Worksheets.Add()
                        excWks.Name = Format(Date, "m-dd-yy") 
                    Else
                        Set excWks = excWkb.Worksheets(1)
                    End If
                Else
                    Set excWkb = excApp.Workbooks.Add()
                    Set excWks = excWkb.Worksheets(1)
                End If
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "Received"
                    .Cells(1, 3) = "Sender"
                End With
                intRow = 2
                'Write messages to spreadsheet
                For Each olkMsg In olkFld.Items
                    If olkMsg.Class = olMail Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.Subject
                        excWks.Hyperlinks.Add Anchor:=excWks.Range("A" & intRow), Address:="outlook:" & olkMsg.EntryID, TextToDisplay:=IIf(olkMsg.Subject = "", "Blank", olkMsg.Subject)
                        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
                        intRow = intRow + 1
                    End If
                Next
                Set olkMsg = Nothing
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    If objFSO.FileExists(strFilename) Then
        excWkb.Save
    Else
        excWkb.SaveAs strFilename
    End If
    excWkb.Close True
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision is for Dan who asked “Is there a way using the original version of your code to include emails in subfolders of the folder selected?” Of course the answer is “yes”. In order to handle sub-folders I had to move code from the main routine (i.e. ExportMessagesToExcel) to a new subroutine called ProcessFolder and add a recursive call (i.e. have that routine call itself once for each subfolder). This allows the code to process the currently selected folder and all its subfolders. Other than that this version is identical to the original version.

Const MACRO_NAME = "Export Messages to Excel (Rev 3)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer

Sub ExportMessagesToExcel()
    Dim strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder, intRow As Integer
    intRow = excWks.UsedRange.Rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
            intRow = intRow + 1
            intMessages = intMessages + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Kris Fong and chirag both of whom asked for a modification to export based on a date range. To accomplish that I’ve added a second InputBox that takes a date range in the form mm/dd/yyyy to mm/dd/yyyy. The code tacks on “12:00am” to the starting date and “11:59pm” to the ending date, which it then uses to filter the folder. The code in this revision is based on the code in the original post, so it doesn’t handle the modifications from the other revisions.

Const MACRO_NAME = "Export Messages to Excel (Rev 4)"

Sub ExportMessagesToExcel()
    Dim olkLst As Object, _
        olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strDateRange As String, _
        arrTemp As Variant, _
        datStart As Date, _
        datEnd As Date
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTemp = Split(strDateRange, "to")
        datStart = IIF(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
        datEnd = IIF(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Christy who asked for the ability to export the “To” and “Attachment” fields (i.e. the names of the attachments not the actual attachments themselves) in addition to the fields the script is already exporting.

Const MACRO_NAME = "Export Messages to Excel (Rev 5)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        olkAtt As Outlook.Attachment, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strAtt As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "To"
            .Cells(1, 5) = "Attachments"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 4) = olkMsg.To
                strAtt = ""
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then
                        strAtt = strAtt & olkAtt.FileName & ", "
                    End If
                Next
                If strAtt <> "" Then
                    strAtt = Left(strAtt, Len(strAtt) - 2)
                End If
                excWks.Cells(intRow, 5) = strAtt
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

This revision is for chirag who asked for two modifications: working off of a date range (the same as in revision 4) and saving the attachments of the items that fall into the date range to a folder on the hard drive. Be sure to edit the EXPORT_FOLDER constant. It contains the path to the folder the attachments will be saved to.

Const MACRO_NAME = "Export Messages to Excel (Rev 6)"

Sub ExportMessagesToExcel()
    'Edit the path on the next line.  This is the folder the code will save the attachments to.  Make sure that the path ends with a \
    Const EXPORT_FOLDER = "c:\SomeFolder\"
    Dim olkLst As Object, _
        olkMsg As Object, _
        olkAtt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strDateRange As String, _
        arrTemp As Variant, _
        datStart As Date, _
        datEnd As Date
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTemp = Split(strDateRange, "to")
        datStart = IIF(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
        datEnd = IIF(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then olkAtt.SaveAsFile EXPORT_FOLDER & olkAtt.FileName
                Next
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

This rev is for Nilesh who asked for a version which appends data to an existing sheet instead of creating a new sheet or overwriting an existing sheet. The code will always write to the same workbook and sheet, and will append the exported data to the bottom of the sheet. Other than that this rev is identical to the code in the original post.

'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "c:\Users\David\Documents\Sample.xlsx"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Sheet1"
Const MACRO_NAME = "Export Messages to Excel (Rev 7)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intExp As Integer, _
        intVersion As Integer
    intVersion = GetOutlookVersion()
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
    Set excWks = excWkb.Worksheets(SHEET_NAME)
    intRow = excWks.UsedRange.Rows.Count + 1
    'Write messages to spreadsheet
    For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
            intRow = intRow + 1
            intExp = intExp + 1
        End If
    Next
    Set olkMsg = Nothing
    excWkb.Close True
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intExp & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Alex who has a special situation. Alex receives messages with an HTML table in the body. In addition to the subject, sender, etc., Alex needs to export the table into the spreadsheet. To accomplish this I’ve added a function that uses regular expressions to parse the table out of the message. I then push the table into the clipboard and paste it into the spreadsheet. The code that copies the HTML to the clipboard is not mine. It comes from this Microsoft support article.

'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "c:\Users\David\Documents\Sample.xlsx"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Sheet1"
Const MACRO_NAME = "Export Messages to Excel (Rev 8)"

Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) _
   As Long
Private Declare Function GlobalAlloc Lib "kernel32" ( _
   ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function SetClipboardData Lib "user32" ( _
   ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
   "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
   ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Function GetClipboardData Lib "user32" ( _
   ByVal wFormat As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
   ByVal lpData As Long) As Long

Private Const m_sDescription = _
                  "Version:1.0" & vbCrLf & _
                  "StartHTML:aaaaaaaaaa" & vbCrLf & _
                  "EndHTML:bbbbbbbbbb" & vbCrLf & _
                  "StartFragment:cccccccccc" & vbCrLf & _
                  "EndFragment:dddddddddd" & vbCrLf
                  
Private m_cfHTMLClipFormat As Long

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intExp As Integer, _
        intVersion As Integer
    intVersion = GetOutlookVersion()
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
    Set excWks = excWkb.Worksheets(SHEET_NAME)
    excApp.Visible = True
    intRow = excWks.UsedRange.Rows.Count + 1
    'Write messages to spreadsheet
    For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
            PutHTMLClipboard GetTable(olkMsg.HTMLBody)
            excWks.Range("D" & intRow).Select
            excWks.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=False
            intRow = intRow + 1
            intExp = intExp + 1
        End If
    Next
    Set olkMsg = Nothing
    excWkb.Close True
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intExp & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function GetTable(strBody As String) As String
    Dim objRegEx As Object, colMatches As Object, varMatch As Variant
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Global = True
        .Pattern = "<table.*?>(.*?)</table>"
        Set colMatches = .Execute(strBody)
    End With
    For Each varMatch In colMatches
        GetTable = varMatch
    Next
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Function

Function RegisterCF() As Long
   'Register the HTML clipboard format
   If (m_cfHTMLClipFormat = 0) Then
      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
   End If
   RegisterCF = m_cfHTMLClipFormat
   
End Function

Public Sub PutHTMLClipboard(sHtmlFragment As String, _
   Optional sContextStart As String = "<HTML><BODY>", _
   Optional sContextEnd As String = "</BODY></HTML>")
   
   Dim sData As String
   
   If RegisterCF = 0 Then Exit Sub
   
   'Add the starting and ending tags for the HTML fragment
   sContextStart = sContextStart & "<!--StartFragment -->"
   sContextEnd = "<!--EndFragment -->" & sContextEnd
   
   'Build the HTML given the description, the fragment and the context.
   'And, replace the offset place holders in the description with values
   'for the offsets of StartHMTL, EndHTML, StartFragment and EndFragment.
   sData = m_sDescription & sContextStart & sHtmlFragment & sContextEnd
   sData = Replace(sData, "aaaaaaaaaa", _
                   Format(Len(m_sDescription), "0000000000"))
   sData = Replace(sData, "bbbbbbbbbb", Format(Len(sData), "0000000000"))
   sData = Replace(sData, "cccccccccc", Format(Len(m_sDescription & _
                   sContextStart), "0000000000"))
   sData = Replace(sData, "dddddddddd", Format(Len(m_sDescription & _
                   sContextStart & sHtmlFragment), "0000000000"))

   'Add the HTML code to the clipboard
   If CBool(OpenClipboard(0)) Then
   
      Dim hMemHandle As Long, lpData As Long
      
      hMemHandle = GlobalAlloc(0, Len(sData) + 10)
      
      If CBool(hMemHandle) Then
               
         lpData = GlobalLock(hMemHandle)
         If lpData <> 0 Then
            
            CopyMemory ByVal lpData, ByVal sData, Len(sData)
            GlobalUnlock hMemHandle
            EmptyClipboard
            SetClipboardData m_cfHTMLClipFormat, hMemHandle
                        
         End If
      
      End If
   
      Call CloseClipboard
   End If

End Sub

I created this revision for Chris who posted a comment asking for a way to

  • Create a new workbook each time the script is run
  • Extract the entire mailbox to the workbook
  • Create a new worksheet for each store (in Outlook a store is an either an Exchange mailbox or PST file)
  • Dump all folders in the store to the same sheet

With everything in a given store going to the same worksheet I thought it might be handy to add a column that shows which folder the item is in. Hopefully that will save Chris some confusion. The rest of the code remains unchanged.

Const MACRO_NAME = "Export Messages to Excel (Rev 9)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer, _
    lngRow As Long

Sub ExportMessagesToExcel()
    Dim strFilename As String, olkSto As Outlook.Store
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        For Each olkSto In Session.Stores
            Set excWks = excWkb.Worksheets.Add()
            excWks.Name = olkSto.DisplayName
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Folder"
                .Cells(1, 2) = "Subject"
                .Cells(1, 3) = "Received"
                .Cells(1, 4) = "Sender"
            End With
            lngRow = 2
            ProcessFolder olkSto.GetRootFolder()
        Next
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(lngRow, 1) = olkFld.Name
            excWks.Cells(lngRow, 2) = olkMsg.Subject
            excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime
            excWks.Cells(lngRow, 4) = GetSMTPAddress(olkMsg, intVersion)
            lngRow = lngRow + 1
            intMessages = intMessages + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Christian who asked if I could modify the code in revision 4 to use the current date in lieu of a date range. Revision 4 prompts for starting and ending dates and then extracts all the messages in the current folder that arrived between those two dates. Instead of prompting for a date range this revision gets today’s date and uses it.

Const MACRO_NAME = "Export Messages to Excel (Rev 10)"

Sub ExportMessagesToExcel()
    Dim olkLst As Object, _
        olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        datStart As Date, _
        datEnd As Date
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        datStart = Date & " 12:00am"
        datEnd = Date & " 11:59pm"
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

I put this revision together for nickyzzz who asked for a solution that exports voting responses. Nickyzzz explained that she routinely sends messages with a document attached asking the recipient to review the document and accept/reject it. She’s using Outlook’s voting buttons to handle the response portion. The code here is that from the original post with a “Vote” column added. For each message the code places the value of the voting button the recipient clicked (i.e. VotingResponse) in that column.

Const MACRO_NAME = "Export Messages to Excel (Rev 11)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "Vote"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 4) = olkMsg.VotingResponse
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

I put this revision together for Gur Pollante who asked for a version that melds revisions 1 and 7. What Gur needs is a version that automates exporting the same folder every day (like revision 1) while appending the data to an existing spreadsheet (like revision 7). He also wants to move the exported message from the source folder to a history folder once the export is complete.

Const MACRO_NAME = "Export Messages to Excel (Rev 12)"

'On the next line edit the path as needed
Const HIST_PATH = "Personal Folder - HISTORY"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folder\Daily"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
    Dim olkMsg As Object, _
        olkFld As Object, _
        olkHst As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        intCnt As Integer
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkFld = OpenOutlookFolder(strFolderPath)
            Set olkHst = OpenOutlookFolder(HIST_PATH)
            If TypeName(olkFld) <> "Nothing" Then
                intVersion = GetOutlookVersion()
                Set excApp = CreateObject("Excel.Application")
                Set excWkb = excApp.Workbooks.Open(strFilename)
                Set excWks = excWkb.ActiveSheet
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "From"
                    .Cells(1, 3) = "Date"
                End With
                intRow = excWks.UsedRange.Rows.Count + 1
                'Write messages to spreadsheet
                For intCnt = olkFld.Items.Count To 1 Step -1
                    Set olkMsg = olkFld.Items(intCnt)
                    'Only export messages, not receipts or appointment requests, etc.
                    If olkMsg.Class = olMail Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.Subject
                        excWks.Cells(intRow, 2) = GetSMTPAddress(olkMsg, intVersion)
                        excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                        intRow = intRow + 1
                        olkMsg.Move olkHst
                    End If
                Next
                Set olkMsg = Nothing
                excWkb.Close True
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is also for Gur Pollante who asked if I could make to modifications to Rev 12. First, he wants to append new data beginning at the first row where the cell in column A is blank instead of the first unused row. This allows him to add a formula in another column, something that would change the first unused row. Second, he’d like to schedule running the script, so it needs to be converted from VBA (which runs inside of an Office product) to VBScript (which runs outside of Office products). With the script converted to VBScript Gur can schedule it to run using Windows’ built in task scheduler.

Instructions.

  1. Start Notepad.
  2. Copy the code from the code snippet box and paste it into Notepad.
  3. Edit the code as needed.
  4. Save the script. You can name it anything you want, just be sure that the file extension is .vbs
  5. Run the script by double-clicking on it.
Const MACRO_NAME = "Export Messages to Excel (Rev 13)"
Const olMail = 43

'On the next line edit the path as needed
Const HIST_PATH = "Personal Folder - HISTORY"

Dim olkApp, olkSes, excApp, excWkb, excWks

'Add as many exports as you need. Each export is controlled by a line like the following
'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folder\Daily", "Data"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME


Sub ExportMessagesToExcel(strFilename, strFolderPath, strSheet)
    Dim olkMsg, olkFld, olkHst, ntRow, intVersion, intCnt
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkApp = CreateObject("Outlook.Application")
            Set olkSes = olkApp.GetNamespace("MAPI")
            olkSes.Logon olkApp.DefaultProfileName
            Set olkFld = OpenOutlookFolder(strFolderPath)
            Set olkHst = OpenOutlookFolder(HIST_PATH)
            If TypeName(olkFld) <> "Nothing" Then
                intVersion = GetOutlookVersion()
                Set excApp = CreateObject("Excel.Application")
                Set excWkb = excApp.Workbooks.Open(strFilename)
                Set excWks = excWkb.Sheets(strSheet)
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "From"
                    .Cells(1, 3) = "Date"
                End With
                intRow = GetFirstBlankRow()
                'Write messages to spreadsheet
                For intCnt = olkFld.Items.Count To 1 Step -1
                    Set olkMsg = olkFld.Items(intCnt)
                    'Only export messages, not receipts or appointment requests, etc.
                    If olkMsg.Class = olMail Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.Subject
                        excWks.Cells(intRow, 2) = GetSMTPAddress(olkMsg, intVersion)
                        excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                        intRow = intRow + 1
                        olkMsg.Move olkHst
                    End If
                Next
                Set olkMsg = Nothing
                excWkb.Close True
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    olkSes.Logoff
    Set olkSes = Nothing
    Set olkApp = Nothing
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkSes.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Private Function GetSMTPAddress(Item, intOutlookVersion)
    Dim olkSnd, olkEnt
    On Error Resume Next
    Select Case intOutlookVersion
        Case 1-13
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion()
    Dim arrVer
    arrVer = Split(olkApp.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg)
    Dim olkPA
    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

Function GetFirstBlankRow()
    Dim intCnt
    intCnt = 1
    Do Until excWks.Cells(intCnt, 1) = ""
        intCnt = intCnt + 1
    Loop
    GetFirstBlankRow = intCnt
End Function

I put this revision together for Leslie Roman who receives messages with information that she needs to parse out of the message body. To accomplish that I’ve modified the code to look for certain keywords in the body and extract everything on the line the keyword is on from the end of the keyword to the end of the line.

Const MACRO_NAME = "Export Messages to Excel (Rev 14)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strBuffer As String, _
        strFilename As String, _
        strTemp As String, _
        arrLines As Variant, _
        varLine As Variant, _
        bolComments As Boolean
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "Name"
            .Cells(1, 5) = "Order#"
            .Cells(1, 6) = "Email"
            .Cells(1, 7) = "Testimonial"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                strBuffer = ""
                bolComments = False
                arrLines = Split(olkMsg.Body, vbCrLf)
                For Each varLine In arrLines
                    strTemp = Trim(varLine)
                    If bolComments Then
                        strBuffer = strBuffer & strTemp
                    Else
                        If Left(strTemp, 6) = "Name: " Then
                            excWks.Cells(intRow, 4) = Mid(strTemp, 7)
                        Else
                            If Left(strTemp, 10) = "Order Id: " Then
                                excWks.Cells(intRow, 5) = Mid(strTemp, 11)
                            Else
                                If Left(strTemp, 9) = "Order #: " Then
                                    excWks.Cells(intRow, 5) = Mid(strTemp, 9)
                                    bolComments = True
                                Else
                                    If Left(strTemp, 7) = "Email: " Then
                                        excWks.Cells(intRow, 6) = Mid(strTemp, 8)
                                    Else
                                        If Left(strTemp, 12) = "Testimonial:" Then
                                            bolComments = True
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                Next
                excWks.Cells(intRow, 7) = strBuffer
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Santhosh Mateti who asked

1) How export the selected mail items which are in same folder? Example : Subject contain “Down”.
2) How to append the exporting mail items to exiting Excel ?

This version is essentially the same as revision 2 with the exception that it doesn’t link to the original message and only processes messages that have the word “down” in the subject line.

'On the next line change the value to True if you want each export to go on a new sheet.
Const EXPORT_NEWSHEET = False
Const MACRO_NAME = "Export Messages to Excel (Rev 15)"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
    ExportMessagesToExcel "C:\Folder2.xlsx", "Personal Folders\Folder2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
    Dim olkMsg As Object, _
        olkFld As Outlook.MAPIFolder, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVer As Integer
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkFld = OpenOutlookFolder(strFolderPath)
            If TypeName(olkFld) <> "Nothing" Then
                intVer = GetOutlookVersion()
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set excApp = CreateObject("Excel.Application")
                If objFSO.FileExists(strFilename) Then
                    Set excWkb = excApp.Workbooks.Open(strFilename)
                    If EXPORT_NEWSHEET Then
                        Set excWks = excWkb.Worksheets.Add()
                        excWks.Name = Format(Date, "m-dd-yy") 
                    Else
                        Set excWks = excWkb.Worksheets(1)
                    End If
                Else
                    Set excWkb = excApp.Workbooks.Add()
                    Set excWks = excWkb.Worksheets(1)
                End If
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "Received"
                    .Cells(1, 3) = "Sender"
                End With
                intRow = 2
                'Write messages to spreadsheet
                For Each olkMsg In olkFld.Items
                    If olkMsg.Class = olMail Then
                        If InStr(1, LCase(olkMsg.Subject), "down") then
                            'Add a row for each field in the message you want to export
                            excWks.Cells(intRow, 1) = olkMsg.Subject
                            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
                            intRow = intRow + 1
                        End If
                    End If
                Next
                Set olkMsg = Nothing
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    If objFSO.FileExists(strFilename) Then
        excWkb.Save
    Else
        excWkb.SaveAs strFilename
    End If
    excWkb.Close True
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision is for Nicolas who asked for a way to merge revisions 1 and 3 in such a way that he can pass the process a path to the Outlook folder he wants to export and have the script export that folder and all its sub-folders. This revision accomplishes that. Nicolas will use the instrucitons from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 16)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
    ExportMessagesToExcel "C:\Folder2.xlsx", "Personal Folders\Folder2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolder As String)
    Dim olkFolder As Outlook.MAPIFolder
    If strFilename <> "" Then
        Set olkFolder = OpenOutlookFolder(strFolder)
        If TypeName(olkFolder) = "Nothing" Then
            MsgBox "Could not find the folder '" & strFolder & "'.  Processing aborted.", vbCritical + vbOKOnly + vbSystemModal, MACRO_NAME
        Else
            intMessages = 0
            intVersion = GetOutlookVersion()
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add
            Set excWks = excWkb.Worksheets(1)
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Subject"
                .Cells(1, 2) = "Received"
                .Cells(1, 3) = "Sender"
            End With
            ProcessFolder olkFolder
            excWkb.SaveAs strFilename
            MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
        End If
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkFolder = Nothing
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder, intRow As Integer
    intRow = excWks.UsedRange.Rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
            intRow = intRow + 1
            intMessages = intMessages + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision is for Christopher. See his comment below, it’s the one dated 2012/12/11 at 12:55 pm., for details.

'On the next line change the value to True if you want each export to go on a new sheet.
Const EXPORT_NEWSHEET = False
'On the next line edit the list of categories you want to export for. The list must be comma-separated values.
Const EXPORT_CATS = "Accepted,Pending,Declined"
'On the next line change the value to the number of characters you want to pull from the beginning of the message.
Const CHAR_LIMIT = 70
Const MACRO_NAME = "Export Messages to Excel (Rev 17)"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
    Dim olkMsg As Object, _
        olkFld As Outlook.MAPIFolder, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intExp As Integer, _
        intRow As Integer, _
        intVer As Integer, _
        arrCat As Variant, _
        arrExp As Variant, _
        varExp As Variant, _
        bolExp As Boolean, _
        strTmp As String
    If strFilename <> "" Then
        If strFolderPath <> "" Then
            Set olkFld = OpenOutlookFolder(strFolderPath)
            If TypeName(olkFld) <> "Nothing" Then
                intVer = GetOutlookVersion()
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set excApp = CreateObject("Excel.Application")
                If objFSO.FileExists(strFilename) Then
                    Set excWkb = excApp.Workbooks.Open(strFilename)
                    If EXPORT_NEWSHEET Then
                        Set excWks = excWkb.Worksheets.Add()
                        excWks.Name = Format(Date, "m-dd-yy")
                    Else
                        Set excWks = excWkb.Worksheets(1)
                    End If
                Else
                    Set excWkb = excApp.Workbooks.Add()
                    Set excWks = excWkb.Worksheets(1)
                End If
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Date"
                    .Cells(1, 2) = "MyName"
                    .Cells(1, 3) = "Company"
                    .Cells(1, 4) = "First"
                    .Cells(1, 5) = "Last"
                    .Cells(1, 6) = "Title"
                    .Cells(1, 7) = "Email"
                    .Cells(1, 8) = "Phone"
                    .Cells(1, 9) = "Industry"
                    .Cells(1, 10) = "2ndContact"
                    .Cells(1, 11) = "Method"
                    .Cells(1, 12) = "Attempt"
                    .Cells(1, 13) = "Result"
                    .Cells(1, 14) = "Message"
                    .Cells(1, 15) = "Notes"
                    .Cells(1, 16) = "Notes 2"
                    .Cells(1, 17) = "Co Size"
                    .Cells(1, 18) = "ID"
                End With
                arrExp = Split(EXPORT_CATS, ",")
                'Write messages to spreadsheet
                For Each olkMsg In olkFld.Items
                    If olkMsg.Class = olMail Then
                        For intRow = 2 To excWks.UsedRange.Rows.Count
                            If excWks.Cells(intRow, 18) = olkMsg.EntryID Then
                                bolFound = True
                                Exit For
                            End If
                        Next
                        If Not bolFound Then intRow = excWks.UsedRange.Rows.Count + 1
                        bolExp = False
                        arrCat = Split(olkMsg.Categories, ",")
                        For Each varExp In arrExp
                            For intExp = LBound(arrCat) To UBound(arrCat)
                                If varExp = arrCat(intExp) Then
                                    bolExp = True
                                    Exit For
                                End If
                            Next
                            If bolExp Then Exit For
                        Next
                        If bolExp Then
                            'Add a row for each field in the message you want to export
                            excWks.Cells(intRow, 1) = Date
                            'On the next line replace John Doe Inc with the name of your company
                            strTmp = Replace(olkMsg.Subject, " call with John Doe Inc", "")
                            If Left(strTmp, 4) = "RE: " or Left(strTmp, 4) = "FW: " Then strTmp = Mid(strTmp, 5)
                            excWks.Cells(intRow, 3) = strTmp
                            excWks.Cells(intRow, 13) = olkMsg.Categories
                            excWks.Cells(intRow, 14) = Left(olkMsg.Body, CHAR_LIMIT)
                            excWks.Cells(intRow, 18) = olkMsg.EntryID
                            intRow = intRow + 1
                        End If
                    End If
                Next
                Set olkMsg = Nothing
            Else
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            End If
        Else
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    If objFSO.FileExists(strFilename) Then
        excWkb.Save
    Else
        excWkb.SaveAs strFilename
    End If
    excWkb.Close True
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision is for Andre. See his comment below, it’s the one dated 2012/12/26 at 2:11 pm., for complete details. In short, Andre receives automated emails letting him know the current storage capacity of servers he works with. Andre needs to extract the message time and a line of information from the body of those messages to an Excel spreadsheet. The code I’ve used to accomplish this is a slight variation of this post’s original code. Andre will use the instructions from the original post to add this code to Outlook and to run it.

Const MACRO_NAME = "Export Messages to Excel (Rev 18)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCnt As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        objFSO As Object, _
        bolExists As Boolean
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set excApp = CreateObject("Excel.Application")
        bolExists = objFSO.FileExists(strFilename)
        If bolExists Then
            Set excWkb = excApp.Workbooks.Open(strFilename)
        Else
            Set excWkb = excApp.Workbooks.Add()
        End If
        'On the next line change the sheet number as needed
        Set excWks = excWkb.Worksheets(1)
        If bolExists Then
            intRow = excWks.UsedRange.Rows.Count + 1
        Else
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Received"
                .Cells(1, 2) = "Data"
            End With
            intRow = 2
        End If
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 2) = FindString(olkMsg.Body, "(.*?) has exceeded its upper threshold limits for disk space by (.*?) percent")
                intRow = intRow + 1
                intCnt = intCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        If bolExists Then
            excWkb.Close True
        Else
            excWkb.SaveAs strFilename
            excWkb.Close
        End If
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set objFSO = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

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

This revision is for Molly. Molly is using a custom Outlook form and needs to export the form’s custom fields along with a couple of the stock fields. This version is designed to be called from a rule, although I can modify it to run manually if that’s what Molly needs.

Adding the code to Outlook.

  1. Start Outlook
  2. Press ALT+F11 to open the 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 per the comments I included in it
  8. Click the diskette icon on the toolbar to save the changes
  9. Close the VB Editor
  10. Create a rule that fires for these messages
  11. Set the rule’s action to “run a script” and select HandleAnalystRequestForm as the macro to run
'Declare some constants
'On the next line edit the path to the workbook 
Const WORKBOOK_PATH = "C:\Users\David\Documents\TestArea\Molly.xlsx"
Const MACRO_NAME = "Export Messages to Excel (Rev 19)"

Sub HandleAnalystRequestForm(Item As Outlook.MailItem)
    If Item.MessageClass = "IPM.Note.Analyst Request Form" Then
        ExportFormToExcel Item, WORKBOOK_PATH, 1
    End If
End Sub

Sub ExportFormToExcel(olkMsg As Outlook.MailItem, strWorkbook As String, intSheet As Integer)
    'Declare some variables
    Dim excApp As Object, excWkb As Object, excWks As Object

    'Connect to Excel
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(strWorkbook)
    Set excWks = excWkb.Worksheets(intSheet)

    'Add a row to the spreadsheet
    intRow = excWks.UsedRange.Rows.Count + 1

    'Write the data to the spreadsheet.  Add a row for each field in the message you want to export.
    excWks.Cells(intRow, 1) = olkMsg.To
    excWks.Cells(intRow, 2) = olkMsg.CC
    excWks.Cells(intRow, 3) = olkMsg.UserProperties.Item("Trans").Value
    excWks.Cells(intRow, 4) = olkMsg.UserProperties.Item("Situation").Value
    excWks.Cells(intRow, 5) = olkMsg.UserProperties.Item("Question").Value
    excWks.Cells(intRow, 6) = olkMsg.UserProperties.Item("Potential Solution").Value
    excWks.Cells(intRow, 7) = olkMsg.UserProperties.Item("Response").Value
    excWks.Cells(intRow, 8) = olkMsg.UserProperties.Item("Next Steps").Value

    'Save and close the workbook
    excWkb.Close True

    'Clean-up open objects to avoid memory leaks
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

To be filled in later.

I put this version together for Thomas who asked me to merge various pieces of other version together for him. Outlook triggers the code via a rule. When it runs it extracts four pieces of data in the body of the message, writes the data to the spreadsheet, moves the triggering message to an Outlook folder, and runs an Excel macro. Thomas must edit the three constants at the top of the code per the instructions I included in the code for the script to work. The instructions for adding this code to Outlook are the same as for the original version of the code in this post.

'Declare some constants
'On the next line edit the path to the workbook
Const WORKBOOK_PATH = "C:\Users\David\Documents\TestArea\Kleppinger.xlsm"
'On the next line edit the path to the Outlook folder the message will be mvoed to after processing it
Const FOLDER_PATH = "Personal Folders\History"
'On the next line edit the name of the Excel macro to run after the data is added to Excel.  Be sure to include the name of the module the macro is in.
Const EXCEL_MACRO = "Sheet1.Macro_Email"
Const MACRO_NAME = "Export Messages to Excel (Rev 21)"

Sub ExportMessagesToExcel(Item As Outlook.MailItem)
    'Declare some variables
    Dim excApp As Object, excWkb As Object, excWks As Object, arrRows As Variant, arrRow As Variant, varRow As Variant, intRow
    
    'Get the folder object of the folder the message is to be moved to
    Set olkFld = OpenOutlookFolder(FOLDER_PATH)

    'Connect to Excel
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
    Set excWks = excWkb.Worksheets(1)

    'Set the row number to change
    intRow = 1
    
    'Get data from the message and put it into the spreadsheet
    arrRows = Split(Item.Body, vbCrLf)
    For Each varRow In arrRows
        If InStr(1, varRow, ":") > 0 Then
            arrRow = Split(varRow, ":")
            Select Case arrRow(0)
                Case "A"
                    excWks.Cells(intRow, 1) = arrRow(1)
                Case "B"
                    excWks.Cells(intRow, 2) = arrRow(1)
                Case "C"
                    excWks.Cells(intRow, 3) = arrRow(1)
                Case "D"
                    excWks.Cells(intRow, 4) = arrRow(1)
            End Select
        End If
    Next
    
    'Move the message to a folder
    Item.Move olkFld
    
    'Run an Excel macro
    excApp.Run EXCEL_MACRO
    
    'Save and close the workbook
    excWkb.Close True

    'Clean-up open objects to avoid memory leaks
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision is a knock-off of Revision 5. I put it together for Yogesh Patel who is using Rev 5 and asked if I could add the ability to “… extract (save) attachments to a defined folder and also create the log.” Yogesh will need to edit the ATTACHMENT_PATH constant to point to the folder he wants to save attachments to. As it saves each attachment the code checks to see if an attachment with that name already exists in the folder. If it does, then it prepends “Copy (x)” to the file name. This precludes overwriting attachments with the same name. The instructions for adding this code to Outlook are the same as for the original version of the code in this post.

Const MACRO_NAME = "Export Messages to Excel (Rev 22)"
'On the nest line edit the path to the folder you want to save attachments to.  The path name must end with a \
Const ATTACHMENT_PATH = "c:\Users\David\Documents\TestArea\YogeshPatel\"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        olkAtt As Outlook.Attachment, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        intCount As Integer, _
        strFilename As String, _
        strAtt As String, _
        strSaveFilePath As String, _
        objFSO As Object
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "To"
            .Cells(1, 5) = "Attachments"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 4) = olkMsg.To
                strAtt = ""
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then
                        strAtt = strAtt & olkAtt.Filename & ", "
                        intCount = 0
                        strSaveFilePath = ATTACHMENT_PATH & olkAtt.Filename
                        Do While objFSO.FileExists(strSaveFilePath)
                            intCount = intCount + 1
                            strSaveFilePath = ATTACHMENT_PATH & "Copy (" & intCount & ") of " & olkAtt.Filename
                        Loop
                        olkAtt.SaveAsFile strSaveFilePath
                    End If
                Next
                If strAtt <> "" Then
                    strAtt = Left(strAtt, Len(strAtt) - 2)
                End If
                excWks.Cells(intRow, 5) = strAtt
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set objFSO = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

I put this revision together for Tom who posted a comment asking for a version that would

  1. Be triggered by a rule.
  2. Extract text from the subject line of the message that triggered the rule. The text appears between two colons.
  3. Connect to an already open Excel workbook.
  4. Write the extracted text to column D on the first line where column D is blank.

The instructions for adding this code to Outlook are the same as for the original version of the code at the beginning of this post.

Sub ExportMessagesToExcel(olkMsg As Outlook.MailItem)
    '--> Create some constants
    'On the next line edit the name of the workbook
    Const WBK_NAME = "Book1"
    'On the next line edit the name of the worksheet
    Const WKS_NAME = "Sheet1"
    Const MACRO_NAME = "Export Messages to Excel (Rev 23)"
    
    '--> Create some variables
    Dim excApp As Object, excWkb As Object, excWks As Object, lngRow As Long, strTxt As String, intP1 As Integer, intP2 As Integer
    
    '--> Turn error handling off
    On Error Resume Next
    
    '--> Main routine
    intP1 = InStr(1, olkMsg.Subject, ":")
    intP2 = InStrRev(olkMsg.Subject, ":")
    strTxt = Mid(olkMsg.Subject, intP1 + 1, intP2 - (intP1 + 1))
    Set excApp = GetObject(, "Excel.Application")
    If TypeName(excApp) = "Nothing" Then
        MsgBox "The spreadsheet was not open.  Operation aborted.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        Set excWkb = excApp.Workbooks.Item(WBK_NAME)
        If TypeName(excWkb) = "Nothing" Then
            MsgBox "The workbook named " & WBK_NAME & " isn't open.  Operation aborted.", vbCritical + vbOKOnly, MACRO_NAME
        Else
            Set excWks = excWkb.Worksheets.Item(WKS_NAME)
            If TypeName(excWks) = "Nothing" Then
                MsgBox "The workbook doesn't have a worksheet named " & WKS_NAME & ".  Operation aborted.", vbCritical + vbOKOnly, MACRO_NAME
            Else
                lngRow = 1
                Do Until excWks.Cells(lngRow, 4) = ""
                    lngRow = lngRow + 1
                Loop
                excWks.Cells(lngRow, 4) = strTxt
            End If
        End If
    End If
    
    '--> Cleanup
    Set excApp = Nothing
    Set excWkb = Nothing
    Set excWks = Nothing
End Sub

This revision is for Tanveer who asked for a knockoff of revision 6 with the added ability of giving each saved attachment a unique filename. The filename will be the attachment name plus an incremental number.

The instructions for adding this code to Outlook are the same as for the original version of the code in this post.

Const MACRO_NAME = "Export Messages to Excel (Rev 24)"

Sub ExportMessagesToExcel()
    'Edit the path on the next line.  This is the folder the code will save the attachments to.  Make sure that the path ends with a \
    Const EXPORT_FOLDER = "C:\SomeFolder\"
    Dim olkLst As Object, _
        olkMsg As Object, _
        olkAtt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        objFSO As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        intCount As Integer, _
        strFilename As String, _
        strDateRange As String, _
        strTemp As String, _
        arrTemp As Variant, _
        datStart As Date, _
        datEnd As Date
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTemp = Split(strDateRange, "to")
        datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
        datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
        intVersion = GetOutlookVersion()
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "Attachments"
        End With
        intRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then
                        intCount = 0
                        strTemp = olkAtt.Filename
                        Do While objFSO.FileExists(EXPORT_FOLDER & strTemp)
                            intCount = intCount + 1
                            strTemp = objFSO.GetBaseName(olkAtt.Filename) & " " & intCount & "." & objFSO.GetExtensionName(olkAtt.Filename)
                        Loop
                        olkAtt.SaveAsFile EXPORT_FOLDER & strTemp
                        excWks.Cells(intRow, 4).Value = excWks.Cells(intRow, 4).Value & strTemp & vbCrLf
                    End If
                Next
                If Len(excWks.Cells(intRow, 4).Value) > 0 Then
                    excWks.Cells(intRow, 4).Value = Left(excWks.Cells(intRow, 4).Value, Len(excWks.Cells(intRow, 4).Value) - 1)
                End If
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

I put this revision together for Nicholas K. who asked for a solution that parses out all the hyperlinks in each message and writes them to successive columns in the spreadsheet. With the exception of that addition, this version is identical to the code from the original post. Nicholas will use the instructions from the original post to add this code to Outlook.

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCol As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        arrHyp As Variant, _
        varhyp As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intCol = 4
                arrHyp = Split(GetLinks(olkMsg.HTMLBody), "|")
                For Each varhyp In arrHyp
                    excWks.Cells(intRow, intCol) = varhyp
                    intCol = intCol + 1
                Next
                intRow = intRow + 1
            End If
        Next
        excWks.Columns("A:ZZ").AutoFit
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function GetLinks(strHTML As String) As String
    Const READYSTATE_COMPLETE = 4
    Dim objIE As Object, objDoc As Object, colLinks As Object, objLink As Object
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.navigate "about:blank"
    Do Until objIE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    objIE.document.Body.innerHTML = strHTML
    Set objDoc = objIE.document
    Set colLinks = objDoc.getElementsByTagName("a")
    If colLinks.Length > 0 Then
        For Each objLink In colLinks
            GetLinks = GetLinks & objLink.href & "|"
        Next
        GetLinks = Left(GetLinks, Len(GetLinks) - 1)
    Else
        GetLinks = ""
    End If
    Set objLink = Nothing
    Set colLinks = Nothing
    Set objDoc = Nothing
    Set objIE = Nothing
End Function

This revision is for Malcolm who needs to extract two pieces of information from the body of certain messages. The code is a knock-off of revision 14, changed to watch for the key text in Macolm’s messages and extract the data that appears after it. Malcolm will use the instructions from the original post to add the code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 26)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strTemp As String, _
        arrLines As Variant, _
        varLine As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "Contact #"
            .Cells(1, 5) = "Email"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                arrLines = Split(olkMsg.Body, vbCrLf)
                For Each varLine In arrLines
                    strTemp = Trim(varLine)
                    If Left(strTemp, 16) = "Contact number: " Then
                        excWks.Cells(intRow, 4) = Mid(strTemp, 17)
                    Else
                        If Left(strTemp, 15) = "Email Address: " Then
                            excWks.Cells(intRow, 5) = Mid(strTemp, 16)
                        End If
                    End If
                Next
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Laura. Laura receives messages from an automated process each containing an HTML table in the message body. She needs to pull three pieces of data from that table, each piece located in a different cell. To do that, I wrote a function that returns an array of the cells, then simply get the contents of the three cells Laura needs. The rest of the code is essentially the same as that in the original post. Laura will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 27)"

Private Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCnt As Integer, _
        strFilename As String, _
        arrCells As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Date"
            .Cells(1, 4) = "Email"
            .Cells(1, 5) = "Count"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Get the cells from the table in the body of the message
                arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255))
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = Left(arrCells(12), 19)
                excWks.Cells(intRow, 4) = arrCells(16)
                excWks.Cells(intRow, 5) = arrCells(14)
                intRow = intRow + 1
                intCnt = intCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetCells(strHTML As String) As String
    Const READYSTATE_COMPLETE = 4
    Dim objIE As Object, objDoc As Object, colCells As Object, objCell As Object
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.navigate "about:blank"
    Do Until objIE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    objIE.document.Body.innerHTML = strHTML
    Set objDoc = objIE.document
    Set colCells = objDoc.getElementsByTagName("td")
    If colCells.Length > 0 Then
        For Each objCell In colCells
            GetCells = GetCells & objCell.innerText & Chr(255)
        Next
        GetCells = Left(GetCells, Len(GetCells) - 1)
    Else
        GetCells = ""
    End If
    Set objCell = Nothing
    Set colCells = Nothing
    Set objDoc = Nothing
    Set objIE = Nothing
End Function

This revision is for Aiyana. Aiyana was sent a message with multiple message items attached. For each attachment, Aiyana needs to parse data from the body of the item and put it in certain rows in the spreadsheet. The data from each message will go in one column of the spreadsheet. Aiyana will use the instructions from the original post to add this code to Outlook. To use the script, Aiyana will select the message containing the attachments and then run the macro.

Const MACRO_NAME = "Export Messages to Excel (Rev 28)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        olkAtt As Object, _
        olkTmp As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intCol As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        intCol = 1
        'Write attachment bodies to the spreadsheet
        Set olkMsg = Application.ActiveExplorer.Selection(1)
        For Each olkAtt In olkMsg.Attachments
            If Right(LCase(olkAtt.Filename), 4) = ".msg" Then
                olkAtt.SaveAsFile Environ("TEMP") & "\" & olkAtt.Filename
                Set olkTmp = Application.CreateItemFromTemplate(Environ("TEMP") & "\" & olkAtt.Filename)
                excWks.Cells(1, intCol) = StripChar(Replace(FindString(olkTmp.Body, "name:(.+)\r\n"), "name: ", ""))
                excWks.Cells(2, intCol) = StripChar(Replace(FindString(olkTmp.Body, "email:(.+)\r\n"), "email: ", ""))
                excWks.Cells(3, intCol) = StripChar(Replace(FindString(olkTmp.Body, "company:(.+)\r\n"), "company: ", ""))
                excWks.Cells(4, intCol) = StripChar(Replace(FindString(olkTmp.Body, "city:(.+)\r\n"), "city: ", ""))
                excWks.Cells(5, intCol) = StripChar(Replace(FindString(olkTmp.Body, "branch:(.+)\r\n"), "branch: ", ""))
                excWks.Cells(6, intCol) = StripChar(Replace(FindString(olkTmp.Body, "design:(.+)\r\n"), "design: ", ""))
                excWks.Cells(7, intCol) = StripChar(Replace(FindString(olkTmp.Body, "satisfaction:(.+)\r\n"), "satisfaction: ", ""))
                excWks.Cells(8, intCol) = StripChar(Replace(FindString(olkTmp.Body, "response:(.+)\r\n"), "response: ", ""))
                excWks.Cells(9, intCol) = StripChar(Replace(FindString(olkTmp.Body, "frequency:(.+)\r\n"), "frequency: ", ""))
                excWks.Cells(10, intCol) = StripChar(Replace(FindString(olkTmp.Body, "delivery:(.+)\r\n"), "delivery: ", ""))
                excWks.Cells(11, intCol) = StripChar(Replace(FindString(olkTmp.Body, "aftersales:(.+)\r\n"), "aftersales: ", ""))
                excWks.Cells(12, intCol) = StripChar(Replace(FindString(olkTmp.Body, "total:(.+)\r\n"), "total: ", ""))
                excWks.Cells(13, intCol) = StripChar(Replace(FindString(olkTmp.Body, "referencecompany:(.+)\r\n"), "referencecompany: ", ""))
                excWks.Cells(14, intCol) = StripChar(Replace(FindString(olkTmp.Body, "referencecontact:(.+)\r\n"), "referencecontact: ", ""))
                excWks.Cells(15, intCol) = StripChar(Replace(FindString(olkTmp.Body, "referenceemail:(.+)\r\n"), "referenceemail: ", ""))
                excWks.Cells(16, intCol) = StripChar(Replace(FindString(olkTmp.Body, "message:(.+)\b"), "message: ", ""))
                intCol = intCol + 1
            End If
            Set olkTmp = Nothing
        Next
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkMsg = Nothing
    Set olkAtt = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private 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 = True
        .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

Private Function StripChar(strValue As String) As String
    StripChar = Replace(strValue, vbCr, "")
    StripChar = Replace(StripChar, vbLf, "")
    StripChar = Replace(StripChar, vbTab, "")
    StripChar = Trim(StripChar)
End Function 

I created this revision for Juan Carlos Rodriguez. Juan asked for a version that exports all the messages in the selected folder and all that folder’s sub-folders with a couple of twists. He wants the export to write each message’s subject, recipients (both those it was sent to and those that were CC’d), the sender’s name, a list of attachments, and the message’s unique ID. Juan also wants the export to create a file system folder for each message and save a copy of the message, in plain-text format, and all attachments to that folder. Finally, he wants a link to each message’s folder added to the spreadsheet.

Juan will follow the instructions from the original post to add the code to Outlook. When he is ready to run the macro, he will

  1. Select a folder in Outlook
  2. Run the macro RunExportMessagesToExcel
'--> Declare some constants
'On the next line edit the path to the folder you want to export the messages to.  The macro will create a sub-folder under this folder for each message.
Const ROOT_PATH = "C:\Users\David\Documents\TestArea\JCR"
Const MACRO_NAME = "Export Messages to Excel (Rev 29)"

'--> Declare some variables
Private excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        objFSO As Object, _
        lngCnt As Long, _
        lngRow As Long

Sub RunExportMessagesToExcel()
    '--> Declare some variables
    Dim strWkb As String
    strWkb = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strWkb <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'Connect to Excel
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Folder"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "To"
            .Cells(1, 4) = "From"
            .Cells(1, 5) = "CC"
            .Cells(1, 6) = "Attachments"
            .Cells(1, 7) = "ID"
            .Cells(1, 8) = "Link"
        End With
        lngRow = 2
        ExportMessagesToExcel Application.ActiveExplorer.CurrentFolder
        excWks.Columns("A:H").AutoFit
        excWkb.SaveAs strWkb
        excWkb.Close
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        Set objFSO = Nothing
        MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
    Else
        MsgBox "Operation canceled.", vbInformation + vbOKOnly, MACRO_NAME
    End If
End Sub

Private Sub ExportMessagesToExcel(olkFol As Outlook.MAPIFolder)
    '--> Declare some variables
    Dim olkMsg As Object, _
        olkAtt As Object, _
        olkSub As Object, _
        objFol As Object, _
        strAtt As String
    'Process the current folder and write its messages to the spreadsheet
    For Each olkMsg In olkFol.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            strAtt = ""
            'Create a new file system folder to store the message and its attachments
            Set objFol = objFSO.CreateFolder(ROOT_PATH & "\" & olkMsg.EntryID)
            'Save a plain-text version of the email to the folder
            olkMsg.SaveAs objFol.Path & "\Message.txt", olTXT
            'Save the attachments to the folder
            For Each olkAtt In olkMsg.Attachments
                If Not IsHiddenAttachment(olkAtt) Then
                    olkAtt.SaveAsFile objFol.Path & "\" & olkAtt.Filename
                    strAtt = strAtt & olkAtt.Filename & ", "
                End If
            Next
            If Len(strAtt) > 0 Then strAtt = Left(strAtt, Len(strAtt) - 2)
            'Add a row for each field in the message you want to export
            excWks.Cells(lngRow, 1) = olkMsg.Parent.FolderPath
            excWks.Cells(lngRow, 2) = olkMsg.Subject
            excWks.Cells(lngRow, 3) = olkMsg.To
            excWks.Cells(lngRow, 4) = olkMsg.SenderName
            excWks.Cells(lngRow, 5) = olkMsg.CC
            excWks.Cells(lngRow, 6) = strAtt
            excWks.Cells(lngRow, 7) = olkMsg.EntryID
            excWks.Hyperlinks.Add Anchor:=excWks.Range("H" & lngRow, "H" & lngRow), Address:="file://" & objFol.Path, TextToDisplay:="View Original Items"
            lngRow = lngRow + 1
            lngCnt = lngCnt + 1
            Set olkAtt = Nothing
        End If
        DoEvents
    Next
    Set olkMsg = Nothing
    Set objFol = Nothing
    For Each olkSub In olkFol.Folders
        ExportMessagesToExcel olkSub
        DoEvents
    Next
    Set olkSub = Nothing
End Sub

Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    ' Purpose: Determines if an attachment is a hidden attachment.
    ' Written: 7/12/2012
    ' Author:  David Lee
    ' Outlook: 2007 and later
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

I created this revision is for Suhas. Suhas asked for a mashup of capabilities from multiple revisions. Specifically, Suhas wants a version that

  1. Ask for the path and folder name to save the data
  2. Ask for a date range
  3. Export the data from the subfolders based on the date range into the same excel sheet

This version does all three. Suhas will use the instructions from the original post to add the code to Outlook. To run the code, Suhas will

  1. Select a folder. The macro will process that folder and all sub-folders under it.
  2. Run the macro ExportMessagesToExcel.
  3. Enter the path and filename of the file the macro will export the data to. The macro will create this file.
  4. Enter a date range. The macro will only export messages that fall inside the date range Suhas enters.
Const MACRO_NAME = "Export Messages to Excel (Rev 30)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    lngMessages As Long, _
    lngRow As Long, _
    datStart As Date, _
    datEnd As Date

Sub ExportMessagesToExcel()
    Dim strFilename As String, strDateRange As String, arrTemp As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTemp = Split(strDateRange, "to")
        datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
        datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
        lngMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        lngRow = excWks.UsedRange.Rows.Count + 1
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngMessages & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkLst As Object, _
        olkMsg As Object, _
        olkSub As Object
    If olkFld.DefaultItemType = olMailItem Then
        Set olkLst = olkFld.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        'Write messages to spreadsheet
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkMsg.Subject
                excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                lngRow = lngRow + 1
                lngMessages = lngMessages + 1
            End If
        Next
        Set olkMsg = Nothing
    End If
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This is another revision I put together for Saroj. Every hour Saroj receives a message with a body like this

Provider: AFU Service: toxxxxfile MaxLimit: 1 Active: 0 Total: 0
Tasks:
Provider: AFURVGX Service: fltocvx MaxLimit: 5 Active: 0 Total: 1
Tasks:
P1406624a0ef5136ac692
Provider: AFU Service: extractor MaxLimit: 87 Active: 7 Total: 7
Tasks:
Provider: AFU Service: pllxxltoxt MaxLimit: 9 Active: 0 Total: 0
Tasks:
Provider: AFU Service: catly5tooneas MaxLimit: 3 Active: 0 Total: 0
Tasks:
Provider: AFUR Service: urdestoxt MaxLimit: 6 Active: 0 Total: 0
Tasks:
Provider: AFU Service: slcreate MaxLimit: 6 Active: 0 Total: 0
Tasks:
Provider: AFUR Service: caty5tocvx MaxLimit: 23 Active: 5 Total: 8

He needs to be able to extract the number after the word “Active:” and write it to a spreadsheet. All the values from one message will go in different columns on the same row. The solution I’ve put together extracts the same message information as the original post plus the values Saroj needs.

Saroj will follow the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 31)"

Private Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCol As Long, _
        lngCnt As Long, _
        intVersion As Integer, _
        strFilename As String, _
        arrHits As Variant, _
        varHit As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        lngRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkMsg.Subject
                excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                lngCol = 4
                arrHits = Split(FindString(olkMsg.Body, "Active:\s[0-9]*\s"), "|")
                For Each varHit In arrHits
                    excWks.Cells(lngRow, lngCol) = Trim(Replace(varHit, "Active: ", ""))
                    lngCol = lngCol + 1
                Next
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private 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
        For Each objMatch In colMatches
            FindString = FindString & objMatch.Value & "|"
        Next
        FindString = Left(FindString, Len(FindString) - 1)
    Else
        FindString = "Not found"
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
    Set objMatch = Nothing
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

I put this revision together for Jonathan Xiang who asked for a knock-off of rev 30 with a few changes. Specifically

1. I would like to hard-code the sub-folders that the macro has to extract the messages from; And only those folders have to be processed.
2. Instead of a date range; I would like to extract the data of a specific date.
3. If the subject line of the message is empty, then it should skip exporting that message to excel.
4. When extracting to an excel file it should automatically load a pre-defined template and extract the data into “sheet1″.

This rev incorporates all the changes Jonathan asked for. Jonathan can use the instructions from the original post to add the code to Outlook. He will also need to edit two lines at the top of the code per the comments I included in it.

Const MACRO_NAME = "Export Messages to Excel (Rev 32)"
'On the next line edit the list of Outlook folders you want to process. Each folder name must be the path to a folder. Folder names are separated by a comma.
Const FOLDER_LIST = "mailbox\Projects\Project1,personal folders\marketing"
'On the next line edit the path to and name of the Excel template file.
Const TEMPLATE_NAME = "C:\Cooldude_Template.xlsx"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    lngMessages As Long, _
    lngRow As Long, _
    datStart As Date, _
    datEnd As Date

Private Sub ExportMessagesToExcel()
    Dim strFilename As String, strDateRange As String, arrFolders As Variant, varFolder As Variant
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date you want to export messages for in the form ""mm/dd/yy""", MACRO_NAME, Date)
        If IsDate(strDateRange) Then
            datStart = strDateRange & " 12:00am"
            datEnd = strDateRange & " 11:59pm"
        Else
            datStart = Date & " 12:00am"
            datEnd = Date & " 11:59pm"
        End If
        lngMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add(TEMPLATE_NAME)
        Set excWks = excWkb.Worksheets(1)
        lngRow = excWks.UsedRange.Rows.Count + 1
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        arrFolders = Split(FOLDER_LIST, ",")
        For Each varFolder In arrFolders
            ProcessFolder OpenOutlookFolder(CStr(varFolder))
        Next
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngMessages & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkLst As Object, _
        olkMsg As Object
    If olkFld.DefaultItemType = olMailItem Then
        Set olkLst = olkFld.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        'Write messages to spreadsheet
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                If olkMsg.Subject <> "" Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(lngRow, 1) = olkMsg.Subject
                    excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                    excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                    lngRow = lngRow + 1
                    lngMessages = lngMessages + 1
                End If
            End If
        Next
        Set olkMsg = Nothing
    End If
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

I put together this revision for Jesper Jespersen who asked for a mashup of features from revisions 1, 3, and 7. From rev 1 Jesper wants the the ability to specifiy which Outlook folders to process. From rev 3 he wants the ability to process sub-folders. From rev 7 he wants the ability to append the exported data to an existing workbook rather than creating a new one. Jesper also asked for the ability to filter messages based on keywords in the subject line and to export either the time the message was sent or received depending on whether he sent or received the message. This revision contains everything Jesper asked for. Jesper can use the instructions from the original post to add the code to Outlook.

'On the next line edit the list of keywords to search for.  Each keyword will be separated from the previous keyword by a |.
Const KEYWORDS = "word1|word2"
Const MACRO_NAME = "Export Messages to Excel (Rev 33)"

Dim lngRow As Long, _
    lngMessages As Long, _
    intVersion As Integer, _
    excApp As Object, _
    excWkb As Object, _
    excWks As Object
    
Sub ExportController()
    intVersion = GetOutlookVersion()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", "Sheet Number", "Path to Outlook Folder"
    ExportMessagesToExcel "C:\Folder1.xlsx", 1, "Personal Folders\Folder1"
    ExportMessagesToExcel "C:\Folder2.xlsx", 1, "Personal Folders\Folder2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, intSheet As Integer, strFolderPath As String)
    Dim olkFld As Object
    If strFilename = "" Then
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        If strFolderPath = "" Then
            MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
        Else
            Set olkFld = OpenOutlookFolder(strFolderPath)
            If TypeName(olkFld) = "Nothing" Then
                MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
            Else
                Set excApp = CreateObject("Excel.Application")
                Set excWkb = excApp.Workbooks.Open(strFilename)
                Set excWks = excWkb.Worksheets(intSheet)
                lngRow = excWks.UsedRange.rows.Count + 1
                ProcessFolder olkFld
                excWkb.Close SaveChanges:=True
            End If
        End If
    End If
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            If ContainsKeyword(olkMsg.Subject) Then
                excWks.Cells(lngRow, 1) = olkMsg.Subject
                excWks.Cells(lngRow, 2) = IIf(olkMsg.SenderEmailAddress = Session.CurrentUser.Address, olkMsg.SentOn, olkMsg.ReceivedTime)
                excWks.Cells(lngRow, 3) = olkMsg.To
                excWks.Cells(lngRow, 4) = olkMsg.SenderEmailAddress
                excWks.Cells(lngRow, 5) = olkMsg.Parent.FolderPath
                lngRow = lngRow + 1
                lngMessages = lngMessages + 1
            End If
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub

Private Function ContainsKeyword(strText As String) As Boolean
    Dim objRegEx As Object, colMatches As Object
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = KEYWORDS
        .Global = True
    End With
    Set colMatches = objRegEx.Execute(strText)
    ContainsKeyword = (colMatches.Count > 0)
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Function

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

This revision is for Shawn who asked for a version that will

  • Create a new spreadsheet or update an existing spreadsheet.
  • Export messages from a folder based on a date range.
  • Save all attachments from the processed messages to a file system folder.
  • Hyperlink to each saved attachment from the spreadsheet.

To avoid the possibility of duplicate file names, Shawn asked to have a date stamp added to each attachment’s file name.

Shawn can use the instructions from the original post to add the code to Outlook.

'--> Declare some constants
'Edit the path on the next line.  This is the folder the code will save the attachments to.  Make sure the path ends with a \
Const EXPORT_FOLDER = "C:\Users\David\Documents\TestArea\Shawn_Tester\"
Const MACRO_NAME = "Export Messages to Excel (Rev 34)"

Private Sub ExportMessagesToExcel()
    '--> Declare some variables
    Dim olkLst As Object, _
        olkMsg As Object, _
        olkAtt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        objFSO As Object, _
        lngRow As Long, _
        lngCol As Long, _
        lngCnt As Long, _
        intVersion As Integer, _
        strFilename As String, _
        strAttFilename As String, _
        strDateRange As String, _
        arrTemp As Variant, _
        datStart As Date, _
        datEnd As Date, _
        bolNew As Boolean
        
    '--> Initialize some variables
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    intVersion = GetOutlookVersion()
    Set excApp = CreateObject("Excel.Application")
    
    '--> Get a date range from the user.  Parse what they enter into starting and ending dates.
    strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
    arrTemp = Split(strDateRange, "to")
    datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
    datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
    
    '--> Main routine
    If IsDate(datStart) And IsDate(datEnd) Then
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & " " & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        If olkLst.Count > 0 Then
            strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
            If strFilename = "" Then
                MsgBox "You did not enter a filename.  Operation cancelled.", vbInformation + vbOKOnly, MACRO_NAME
            Else
                If objFSO.FileExists(strFilename) Then
                    Set excWkb = excApp.Workbooks.Open(strFilename)
                    Set excWks = excWkb.Worksheets(1)
                    lngRow = excWks.UsedRange.rows.Count + 1
                Else
                    Set excWkb = excApp.Workbooks.Add()
                    Set excWks = excWkb.Worksheets(1)
                    lngRow = 2
                    With excWks
                        .Cells(1, 1) = "Subject"
                        .Cells(1, 2) = "Received"
                        .Cells(1, 3) = "Sender"
                        .Cells(1, 4) = "Attachments"
                    End With
                    bolNew = True
                End If
                For Each olkMsg In olkLst
                    If olkMsg.Class = olMail Then
                        lngCol = 4
                        'Add a row for each field in the message you want to export
                        excWks.Cells(lngRow, 1) = olkMsg.Subject
                        excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                        excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                        For Each olkAtt In olkMsg.Attachments
                            If Not IsHiddenAttachment(olkAtt) Then
                                strAttFilename = EXPORT_FOLDER & objFSO.GetBaseName(olkAtt.Filename) & Format(olkMsg.ReceivedTime, "yyyy-mm-dd-hh-nn-ss") & "." & objFSO.GetExtensionName(olkAtt.Filename)
                                olkAtt.SaveAsFile strAttFilename
                                excWks.Hyperlinks.Add Anchor:=excWks.Range(NumberToLetter(lngCol) & lngRow), Address:="FILE:\\" & strAttFilename, TextToDisplay:=olkAtt.Filename
                                lngCol = lngCol + 1
                            End If
                        Next
                        lngRow = lngRow + 1
                        lngCnt = lngCnt + 1
                    End If
                Next
                If bolNew Then
                    excWkb.SaveAs strFilename
                    excWkb.Close
                Else
                    excWkb.Close True
                End If
            End If
        Else
            MsgBox "I did not find any items that arrived between " & datStart & " and " & datEnd & ".  Operation cancelled.", vbInformation + vbOKOnly, MACRO_NAME
        End If
    End If

    '--> Destroy all objects
    Set olkLst = Nothing
    Set olkMsg = Nothing
    Set olkAtt = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set objFSO = Nothing
    
    '--> Let the user know how many items were exported
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Private Function NumberToLetter(ByVal intNumber As Integer) As String
    NumberToLetter = Chr(64 + intNumber)
End Function

I created this revision for Stefan. Stefan receives messages containing a single HTML table. He asked if I could build a solution that parses the table and exports the data to Excel. The table contains a variable number of rows with each row containing a fixed number of columns. Stefan wants the exported data to be laid out exactly as it was in the table. One of the columns contains a very long number which Excel normally displays using scientific notation (e.g. 1.00E+12). Stefan asked if I could also force that column to display as a regular number.

Stefan can use the instructions from the original post to add the code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 35)"

Private Sub ExportMessagesToExcel()
    Const CELLS_PER_ROW = 14
    Dim olkFld As Outlook.MAPIFolder, _
        olkMsg As Outlook.MailItem, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        arrCel As Variant, _
        varCel As Variant, _
        lngRow As Long, _
        lngCol As Long, _
        intPtr As Integer
    Set olkFld = Session.PickFolder
    If TypeName(olkFld) = "Nothing" Then
        MsgBox "You did not select a folder.  Operation cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        excApp.Visible = True
        With excWks
            .Cells(1, 1) = "Time"
            .Cells(1, 2) = "ReceipientID"
            .Cells(1, 3) = "Shard"
            .Cells(1, 4) = "SenderEmail"
            .Cells(1, 5) = "Status"
            .Cells(1, 6) = "SenderClientIP"
            .Cells(1, 7) = "SenderID"
            .Cells(1, 8) = "SederName"
            .Cells(1, 9) = "Group"
            .Cells(1, 10) = "MailCount"
            .Cells(1, 11) = "SampleSubject"
            .Cells(1, 12) = "SampleNumber"
            .Cells(1, 13) = "SumNumber"
            .Cells(1, 14) = "SampleBody"
        End With
        lngRow = 2
        For Each olkMsg In olkFld.Items
            arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
            lngCol = 1
            For intPtr = LBound(arrCel) To UBound(arrCel)
                If lngCol = 2 Then
                    excWks.Cells(lngRow, lngCol).NumberFormat = "@"
                End If
                excWks.Cells(lngRow, lngCol).Value = arrCel(intPtr)
                If (intPtr + 1) Mod CELLS_PER_ROW = 0 Then
                    lngRow = lngRow + 1
                    lngCol = 1
                Else
                    lngCol = lngCol + 1
                End If
            Next
        Next
        excWks.Columns("A:N").AutoFit
        excApp.Visible = True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
    End If
    Set olkFld = Nothing
End Sub

Private Function GetCells(strHTML As String) As String
    Const READYSTATE_COMPLETE = 4
    Dim objIE As Object, objDoc As Object, colCells As Object, objCell As Object
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.navigate "about:blank"
    Do Until objIE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    objIE.document.Body.innerHTML = strHTML
    Set objDoc = objIE.document
    Set colCells = objDoc.getElementsByTagName("td")
    If colCells.Length > 0 Then
        For Each objCell In colCells
            GetCells = GetCells & objCell.innerText & Chr(255)
        Next
        GetCells = Left(GetCells, Len(GetCells) - 1)
    Else
        GetCells = ""
    End If
    Set objCell = Nothing
    Set colCells = Nothing
    Set objDoc = Nothing
    objIE.Quit
    Set objIE = Nothing
End Function 

I created this revision for Luis. It is identical to the code in the original post with the exception that Luis also needs the To and Body fields of the message.

Luis can use the instructions from the original post to add the code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 36)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCnt As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Receiver"
            .Cells(1, 3) = "Received"
            .Cells(1, 4) = "Subject"
            .Cells(1, 5) = "Body"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 2) = olkMsg.To
                excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 4) = olkMsg.Subject
                excWks.Cells(intRow, 5) = olkMsg.Body
                intRow = intRow + 1
                intCnt = intCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.VERSION, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) 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

I put this revision together for a reader named Cleverson who asked for a couple of changes to the original version. Specifically, Cleverson asked for a version that exports a given folder each time rather than having to select a folder to export. He also asked me to rearrange the order of the exported fields.

Cleverson can use the instructions from the original post to add the code to Outlook.

'On the next line edit the path to the Outlook folder you want to export
Const FOLDER_PATH = "Mailbox - Doe, John\Inbox"
Const MACRO_NAME = "Export Messages to Excel (Rev 37)"

Private Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        olkFld As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCnt As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename = "" Then
        MsgBox "You did not enter the path and name of a file to save the export to.  Export cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        Set olkFld = OpenOutlookFolder(FOLDER_PATH)
        If TypeName(olkFld) = "Nothing" Then
            MsgBox "The folder " & FOLDER_PATH & " does not exist.  Export cancelled.", vbCritical + vbOKOnly, MACRO_NAME
        Else
            intVersion = GetOutlookVersion()
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add()
            Set excWks = excWkb.Worksheets(1)
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Received"
                .Cells(1, 2) = "Sender"
                .Cells(1, 3) = "Subject"
            End With
            intRow = 2
            'Write messages to spreadsheet
            For Each olkMsg In olkFld.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
                    excWks.Cells(intRow, 2) = GetSMTPAddress(olkMsg, intVersion)
                    excWks.Cells(intRow, 3) = olkMsg.Subject
                    intRow = intRow + 1
                    intCnt = intCnt + 1
                End If
            Next
            Set olkMsg = Nothing
            excWks.Columns("A:C").AutoFit
            excWkb.SaveAs strFilename
            excWkb.Close
            MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
        End If
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision goes out to a reader named Allen who needs to export data from a custom Outlook form rather than a stock Outlook message. Allen only wants to export the user-defined fields he’s added to his custom form. While this revision will only work for Allen’s form, it demonstrates how an export can handle custom form fields. All you need to know is the name of the custom form (required to ensure that we only process instances of that form and not regular messages which wouldn’t have the custom fields) and the names of the fields on the custom form.

Allen will use the instructions from the original post to add this code to Outlook.

Sub ExportMessagesToExcel()
    'On the next line edit the custom form's name as needed.
    Const CUSTOM_FORM_NAME = "IPM.Note.Near Miss Log"
    Const MACRO_NAME = "Export Messages to Excel (Rev 38)"
    Dim olkMsg As Object, _
        olkUDP As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFilename = "" Then
        MsgBox "You failed to enter a filename.  Export cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Incident"
            .Cells(1, 2) = "Corrective Action"
            .Cells(1, 3) = "GRG"
            .Cells(1, 4) = "Incident Date"
            .Cells(1, 5) = "Location Drop"
            .Cells(1, 6) = "Location Name"
            .Cells(1, 7) = "Medical Treatment"
            .Cells(1, 8) = "Message"
            .Cells(1, 9) = "Name1"
            .Cells(1, 10) = "Potential Root Cause"
            .Cells(1, 11) = "Time1"
            .Cells(1, 12) = "Work Area"
        End With
        lngRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages that use a specific custom form
            If olkMsg.MessageClass = CUSTOM_FORM_NAME Then
                'Add a row for each field in the message you want to export
                For Each olkUDP In olkMsg.UserProperties
                    Select Case olkUDP.Name
                        Case "Brief Description of Incident:"
                            excWks.Cells(lngRow, 1) = olkUDP.Value
                        Case "Description of Corrective Action"
                            excWks.Cells(lngRow, 2) = olkUDP.Value
                        Case "GRG"
                            excWks.Cells(lngRow, 3) = olkUDP.Value
                        Case "Incident Date:"
                            excWks.Cells(lngRow, 4) = olkUDP.Value
                        Case "Location Drop"
                            excWks.Cells(lngRow, 5) = olkUDP.Value
                        Case "Location Name:"
                            excWks.Cells(lngRow, 6) = olkUDP.Value
                        Case "Medical Treatment"
                            excWks.Cells(lngRow, 7) = olkUDP.Value
                        Case "Message"
                            excWks.Cells(lngRow, 8) = olkMsg.Body
                        Case "name1"
                            excWks.Cells(lngRow, 9) = olkUDP.Value
                        Case "Potential Root Cause:"
                            excWks.Cells(lngRow, 10) = olkUDP.Value
                        Case "Time1"
                            excWks.Cells(lngRow, 11) = olkUDP.Value
                        Case "Work Area:"
                            excWks.Cells(lngRow, 12) = olkUDP.Value
                    End Select
                Next
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        Set olkUDP = Nothing
        excWks.Columns("A:L").AutoFit
        excWkb.SaveAs strFilename
        excWkb.Close
        MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

This revision is for Bobby, a reader who asked for a version to handle exporting messages with a unique format. Bobby receives messages about new hires in his company. For each of these messages, Bobby needs to export the new employee’s name, the date they begin work, and the location they’ll be working at. Bobby wants to write these messages to an existing spreadsheet. He will run the macro manually and it will always look for the messages in a specific folder.

Bobby will use the instructions from the original post to add this code to Outlook.

'--> On the next line edit the path to and name of the workbook the extracted data is to be written to
Const EXCEL_WORKBOOK = "C:\Users\Bobby\Documents\Bobby.xlsx"
'--> On the next line edit the path to the Outlook folder containing the messages to be exported
Const OUTLOOK_FOLDER = "Mailbox - Bobby\Inbox\New Hires"
Const NOTE_NAME = "Export Messages to Excel - Last Run"
Const MACRO_NAME = "Export Messages to Excel (Rev 39)"

Sub ExportMessagesToExcel()
    Dim olkFld As Object, _
        olkMsg As Object, _
        olkNot As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        strFil As String, _
        strTmp As String, _
        arrLin As Variant, _
        varLin As Variant, _
        datLst As Date
    On Error Resume Next
    Set olkNot = Session.GetDefaultFolder(olFolderNotes).Items.Item(NOTE_NAME)
    On Error GoTo 0
    If TypeName(olkNot) = "Nothing" Then
        Set olkNot = Application.CreateItem(olNoteItem)
        olkNot.Body = NOTE_NAME & vbCrLf & #1/1/2000 12:01:00 AM#
        olkNot.Save
    End If
    datLst = Replace(olkNot.Body, NOTE_NAME & vbCrLf, "")
    Set olkFld = OpenOutlookFolder(OUTLOOK_FOLDER).Items.Restrict("[ReceivedTime] > '" & Format(datLst, "ddddd h:nn AMPM") & "'")
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(EXCEL_WORKBOOK)
    Set excWks = excWkb.Worksheets(1)
    lngRow = excWks.UsedRange.rows.Count + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            arrLin = Split(olkMsg.Body, vbCrLf)
            For Each varLin In arrLin
                strTmp = Trim(varLin)
                If Left(strTmp, 14) = "Employee Name:" Then
                    excWks.Cells(lngRow, 1) = Trim(Mid(strTmp, 15))
                Else
                    If Left(strTmp, 11) = "Start Date:" Then
                        excWks.Cells(lngRow, 2) = Trim(Mid(strTmp, 12))
                    Else
                        If Left(strTmp, 14) = "Work Location:" Then
                            excWks.Cells(lngRow, 3) = Trim(Mid(strTmp, 15))
                        End If
                    End If
                End If
            Next
            lngRow = lngRow + 1
            lngCnt = lngCnt + 1
        End If
    Next
    olkNot.Body = NOTE_NAME & vbCrLf & Now
    olkNot.Save
    Set olkNot = Nothing
    Set olkFld = Nothing
    Set olkMsg = Nothing
    excWks.Columns("A:C").AutoFit
    excWkb.Close True
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function
 

I put this revision together for a reader named chanakkiyan. Chanakkiyan asked for a version that merges Rev9’s ability to export the entire mailbox with Rev34’s ability to save and hyperlink to the attachments of each exported message.

Chanakkiyan will use the instructions from the original post to add this code to Outlook.

'--> Declare some constants
'On the next line, edit the path on the next line.  This is the folder the code will save the attachments to.  Make sure the path ends with a \
Const EXPORT_FOLDER = "C:\Users\David\Documents\TestArea\chanakkiyan\files\"
'On the next line, edit the path to the spreadsheet you want to export to.
Const EXCEL_WORKSHEET = "C:\Users\David\Documents\TestArea\chanakkiyan\chanakkiyan.xlsx"
Const MACRO_NAME = "Export Messages to Excel (Rev 40)"
 
Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    objFSO As Object, _
    intVer As Integer, _
    lngRow As Long

Sub ExportController()
    Dim olkSto As Object, _
        olkFld As Object

    '--> Initialize some variables
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    intVer = GetOutlookVersion()
    
    '--> Connect to Excel
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(EXCEL_WORKSHEET)
    Set excWks = excWkb.Worksheets(1)
    lngRow = excWks.UsedRange.rows.Count + 1
    
    '--> Main routine
    For Each olkSto In Session.Stores
        Set olkFld = olkSto.GetRootFolder
        ExportMessagesToExcel olkFld
    Next
    excWks.Columns("A:ZZ").AutoFit
    
    '--> Save and close the workbook
    excWkb.Close True
    
    '--> Destroy all objects
    Set olkSto = Nothing
    Set olkFld = Nothing
    Set objFSO = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    
    '--> Notify the user that the process is finished
    MsgBox "Export complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Sub ExportMessagesToExcel(olkFld As Outlook.MAPIFolder)
    '--> Declare some variables
    Dim olkMsg As Object, _
        olkSub As Object, _
        olkAtt As Object, _
        lngCol As Long, _
        strAFN As String, _
        arrTmp As Variant
         
    '--> Main routine
    'Only process folders containing emails, not contacts, calendars, tasks, or notes.
    If olkFld.DefaultItemType = olMailItem Then
        For Each olkMsg In olkFld.Items
            If olkMsg.Class = olMail Then
                lngCol = 5
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkFld.FolderPath
                excWks.Cells(lngRow, 2) = olkMsg.Subject
                excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime
                excWks.Cells(lngRow, 4) = GetSMTPAddress(olkMsg, intVer)
                For Each olkAtt In olkMsg.Attachments
                    If (Not IsHiddenAttachment(olkAtt)) And (Not olkAtt.Type = olOLE) Then
                        strAFN = EXPORT_FOLDER & objFSO.GetBaseName(olkAtt.Filename) & Format(olkMsg.ReceivedTime, "yyyy-mm-dd-hh-nn-ss") & "." & objFSO.GetExtensionName(olkAtt.Filename)
                        olkAtt.SaveAsFile strAFN
                        excWks.Hyperlinks.Add Anchor:=excWks.Range(NumberToLetter(lngCol) & lngRow), Address:="FILE:\\" & strAFN, TextToDisplay:=olkAtt.Filename
                        lngCol = lngCol + 1
                    End If
                Next
                lngRow = lngRow + 1
            End If
        Next
        'Process all the subfolders under this folder
        For Each olkSub In olkFld.Folders
            ExportMessagesToExcel olkSub
        Next
    End If

    '--> Destroy all objects
    Set olkMsg = Nothing
    Set olkSub = Nothing
    Set olkAtt = Nothing
End Sub
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Private Function SMTP2007(olkMsg As Outlook.MailItem) 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
 
Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function
 
Private Function NumberToLetter(ByVal intNumber As Integer) As String
    NumberToLetter = Chr(64 + intNumber)
End Function

I put this revision together for a reader named Singh. Singh has multiple mailboxes and wants to be able to export all the messages from a given mailbox. In rev 3 I showed how to export all the messages from a folder and all it’s subfolders, while in rev 9 I showed how to export messages from every store (mailbox or PST file) in Outlook. In this revision I’ve modified the code from rev 3 to handle just one store (mailbox or PST file).

Singh will use the instructions from the original post to add this code to Outlook.

'On the next line edit the name of the store (mailbox) you want to export
Const STORE_NAME = "Mailbox - Singh"
Const MACRO_NAME = "Export Messages to Excel (Rev 41)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVer As Integer, _
    intCnt As Integer

Sub ExportMessagesToExcel()
    Dim strFil As String
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        intCnt = 0
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        ProcessFolder GetRootFolder(STORE_NAME)
        excWkb.SaveAs strFil
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder, intRow As Integer
    intRow = excWks.UsedRange.rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
            intRow = intRow + 1
            intCnt = intCnt + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function GetRootFolder(strStoreName As String) As Outlook.MAPIFolder
    Dim olkSto As Outlook.Store
    On Error Resume Next
    If strStoreName = "" Then
        Set GetRootFolder = Nothing
    Else
        Set olkSto = Session.Stores.Item(strStoreName)
        If TypeName(olkSto) <> "Nothing" Then
            Set GetRootFolder = olkSto.GetRootFolder
        End If
    End If
    On Error GoTo 0
    Set olkSto = Nothing
End Function

This revision is for David G., a reader who needs to export all the messages in the currently selected folder and all of its sub-folders. For each message, David wants to export the subject, date received, the sender, who the message was sent to, a list of the message’s attachments, who the message was CC’d to, the message body, and the message’s internet header. This solution will only work in Outlook 2007 and later.

David G. will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 42)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVer As Integer, _
    intCnt As Integer

Sub ExportMessagesToExcel()
    Dim strFil As String
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        intCnt = 0
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Date"
            .Cells(1, 3) = "From"
            .Cells(1, 4) = "To"
            .Cells(1, 5) = "Attachment"
            .Cells(1, 6) = "CC"
            .Cells(1, 7) = "Body"
            .Cells(1, 8) = "Header"
        End With
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        excWks.Columns("A:I").AutoFit
        excWkb.SaveAs strFil
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, _
        olkAtt As Object, _
        olkSub As Object, _
        intRow As Integer, _
        strAtt As String
    intRow = excWks.UsedRange.rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Get the names of all attachments
            strAtt = ""
            For Each olkAtt In olkMsg.Attachments
                If Not IsHiddenAttachment(olkAtt) And olkAtt.Type <> olOLE Then
                    strAtt = strAtt & olkAtt.Filename & ", "
                End If
            Next
            If Len(strAtt) > 0 Then
                strAtt = Left(strAtt, Len(strAtt) - 2)
            End If
            'Add a row for each field in the message you want to export
            With excWks
                .Cells(intRow, 1) = olkMsg.Subject
                .Cells(intRow, 2) = olkMsg.ReceivedTime
                .Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
                .Cells(intRow, 4) = olkMsg.To
                .Cells(intRow, 5) = strAtt
                .Cells(intRow, 6) = olkMsg.CC
                .Cells(intRow, 7) = olkMsg.Body
                .Cells(intRow, 8) = GetInetHeaders(olkMsg)
            End With
            intRow = intRow + 1
            intCnt = intCnt + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
    Set olkMsg = Nothing
    Set olkAtt = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  David Lee'
    ' 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

Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    ' Purpose: Determines if an attachment is a hidden attachment.
    ' Written: 7/12/2012
    ' Author:  David Lee
    ' Outlook: 2007 and later
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

This revision is for Abdul who needs to export data from messages containing a 2×4 table. Each message will contain just one table in the message body. The table’s first column contains labels, the second contains the actual data. This solution is a knock-off of the solution I first introduced in revision 27.

Abdul will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 43)"

Private Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intCnt As Integer, _
        strFil As String, _
        arrCel As Variant
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Name"
            .Cells(1, 2) = "ID"
            .Cells(1, 3) = "Education"
            .Cells(1, 4) = "State"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Get the cells from the table in the body of the message
                arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = arrCel(1)
                excWks.Cells(intRow, 2) = arrCel(3)
                excWks.Cells(intRow, 3) = arrCel(5)
                excWks.Cells(intRow, 4) = arrCel(7)
                intRow = intRow + 1
                intCnt = intCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFil
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetCells(strHTML As String) As String
    Const READYSTATE_COMPLETE = 4
    Dim objIE As Object, objDoc As Object, colCells As Object, objCell As Object
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.navigate "about:blank"
    Do Until objIE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    objIE.document.Body.innerHTML = strHTML
    Set objDoc = objIE.document
    Set colCells = objDoc.getElementsByTagName("td")
    If colCells.Length > 0 Then
        For Each objCell In colCells
            GetCells = GetCells & objCell.innerText & Chr(255)
        Next
        GetCells = Left(GetCells, Len(GetCells) - 1)
    Else
        GetCells = ""
    End If
    Set objCell = Nothing
    Set colCells = Nothing
    Set objDoc = Nothing
    Set objIE = Nothing
End Function

This revision is for Wayne who needs to parse three pieces of data from the body of certain messages. This solution is a knock-off of the solution I first introduced in revision 14.

Wayne will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 44)"

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Integer, _
        lngCnt As Long, _
        strFil As String, _
        strTmp As String, _
        arrLin As Variant, _
        varLin As Variant
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Received"
            .Cells(1, 2) = "Name"
            .Cells(1, 3) = "Contact No"
            .Cells(1, 4) = "Email Address"
        End With
        lngRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkMsg.ReceivedTime
                arrLin = Split(olkMsg.Body, vbCrLf)
                For Each varLin In arrLin
                    strTmp = Trim(varLin)
                    If Left(strTmp, 6) = "Name: " Then
                        excWks.Cells(lngRow, 2) = Mid(strTmp, 7)
                    Else
                        If Left(strTmp, 12) = "Contact No: " Then
                            excWks.Cells(lngRow, 3) = Mid(strTmp, 13)
                        Else
                            If Left(strTmp, 15) = "Email Address: " Then
                                excWks.Cells(lngRow, 4) = Mid(strTmp, 16)
                            End If
                        End If
                    End If
                Next
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFil
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

This revision is for Lin who needs to export some basic information (e.g. subject, sender, date received) plus the message body, up to a certain phrase, for all message received in a certain time-frame. The solution is a knock-off of the solution from revision 4 that adds the ability to extract the body of the message up to a designated key phrase. In Lin’s case, that key phrase is the beginning of a disclaimer that appears in each message.

Lin will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 45)"
 
Sub ExportMessagesToExcel()
    Dim olkLst As Object, _
        olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        intVer As Integer, _
        strFil As String, _
        strRng As String, _
        arrTmp As Variant, _
        datBeg As Date, _
        datEnd As Date
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        strRng = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTmp = Split(strRng, "to")
        datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & " 12:00am"
        datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & " 11:59pm"
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "Body"
        End With
        lngRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkMsg.Subject
                excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
                excWks.Cells(lngRow, 4) = GetMsgBody(olkMsg.Body)
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFil
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Function SMTP2007(olkMsg As Outlook.MailItem) 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

Function GetMsgBody(strTxt As String) As String
    Const TEXT_TO_FIND = "The information contained in this message is intended only for the recipient, and may be a confidential"
    Dim lngPos As Long
    lngPos = InStr(1, strTxt, TEXT_TO_FIND, vbTextCompare)
    If lngPos > 0 Then
        GetMsgBody = Left(strTxt, lngPos - 1)
    Else
        GetMsgBody = strTxt
    End If
End Function

I put this revision together for Jörg who asked for a knock-off of rev 42 with a few additions. Specifically

  1. Adds the BCC recipients (will only show up when he runs it against a folder of sent items)
  2. The path to the folder the message is in
  3. A count of the number of recipients the message is addressed to
  4. The number of attachments
  5. Split the time received into two columns with the date in one and the time in the other

Jörg will use the instructions from the original post to add this code to Outlook.

Const MACRO_NAME = "Export Messages to Excel (Rev 46)"

Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVer As Integer, _
    intCnt As Integer

Sub ExportMessagesToExcel()
    Dim strFil As String
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    If strFil <> "" Then
        intCnt = 0
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Folder"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Date"
            .Cells(1, 4) = "Time"
            .Cells(1, 5) = "From"
            .Cells(1, 6) = "To"
            .Cells(1, 7) = "Attachment"
            .Cells(1, 8) = "CC"
            .Cells(1, 9) = "BCC"
            .Cells(1, 10) = "Body"
            .Cells(1, 11) = "Header"
            .Cells(1, 12) = "Recipients"
            .Cells(1, 13) = "Attachments"
        End With
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        excWks.Columns("A:I").AutoFit
        excWks.Columns("K:M").AutoFit
        excWkb.SaveAs strFil
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, _
        olkAtt As Object, _
        olkSub As Object, _
        intRow As Integer, _
        strAtt As String
    intRow = excWks.UsedRange.rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            Debug.Print olkMsg.Subject
            'Get the names of all attachments
            strAtt = ""
            For Each olkAtt In olkMsg.Attachments
                If Not IsHiddenAttachment(olkAtt) And olkAtt.Type <> olOLE Then
                    strAtt = strAtt & olkAtt.Filename & ", "
                End If
            Next
            If Len(strAtt) > 0 Then
                strAtt = Left(strAtt, Len(strAtt) - 2)
            End If
            'Add a row for each field in the message you want to export
            With excWks
                .Cells(intRow, 1) = olkMsg.Parent.FolderPath
                .Cells(intRow, 2) = olkMsg.Subject
                .Cells(intRow, 3) = Format(olkMsg.ReceivedTime, "yymmdd")
                .Cells(intRow, 4) = Format(olkMsg.ReceivedTime, "hh:nn")
                .Cells(intRow, 5) = GetSMTPAddress(olkMsg, intVer)
                .Cells(intRow, 6) = olkMsg.To
                .Cells(intRow, 7) = strAtt
                .Cells(intRow, 8) = olkMsg.CC
                .Cells(intRow, 9) = olkMsg.BCC
                .Cells(intRow, 10) = olkMsg.Body
                .Cells(intRow, 11) = GetInetHeaders(olkMsg)
                .Cells(intRow, 12) = olkMsg.Recipients.Count
                .Cells(intRow, 13) = olkMsg.Attachments.Count
            End With
            intRow = intRow + 1
            intCnt = intCnt + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
    Set olkMsg = Nothing
    Set olkAtt = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  David Lee'
    ' 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

Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    ' Purpose: Determines if an attachment is a hidden attachment.
    ' Written: 7/12/2012
    ' Author:  David Lee
    ' Outlook: 2007 and later
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

I put this revision together for nbnamp, a reader who asked for a mashup of features from revs 3, 7, and 23. In nbnamp’s own words

Is there a way to mix rev.3, rev.7, and rev.23?
From rev.3: export emails from folder and its subfolders
From rev7: the data to be added to the bottom of an existing spreadsheet
And from rev.23: connect to an already open spreadsheet

This revision does all of those things.

Nbnamp will follow the instructions from the original post to add this code to Outlook.

'On the next line edit the name of the workbook
Const WBK_NAME = "Book1"
'On the next line edit the name of the worksheet
Const WKS_NAME = "Sheet1"
Const MACRO_NAME = "Export Messages to Excel (Rev 47)"
 
Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVer As Integer, _
    lngMsg As Long
 
Sub ExportMessagesToExcel()
    On Error Resume Next
    Set excApp = GetObject(, "Excel.Application")
    If TypeName(excApp) = "Nothing" Then
        MsgBox "Excel is not open.  Operation aborted.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        Set excWkb = excApp.Workbooks.Item(WBK_NAME)
        If TypeName(excWkb) = "Nothing" Then
            MsgBox "The workbook " & WBK_NAME & " is not open.  Operation aborted.", vbCritical + vbOKOnly, MACRO_NAME
        Else
            On Error GoTo 0
            lngMsg = 0
            intVer = GetOutlookVersion()
            Set excWks = excWkb.Worksheets(WKS_NAME)
            ProcessFolder Application.ActiveExplorer.CurrentFolder
            excWkb.Save
            Set excWks = Nothing
            Set excWkb = Nothing
            Set excApp = Nothing
            MsgBox "Process complete.  A total of " & lngMsg & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
        End If
    End If
    On Error GoTo 0
End Sub
 
Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder, lngRow As Long
    lngRow = excWks.UsedRange.rows.Count
    lngRow = lngRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(lngRow, 1) = GetSMTPAddress(olkMsg, intVer)
            excWks.Cells(lngRow, 2) = olkMsg.To
            excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime
            excWks.Cells(lngRow, 4) = olkMsg.Subject
            excWks.Cells(lngRow, 5) = olkMsg.Body
            lngRow = lngRow + 1
            lngMsg = lngMsg + 1
        End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

I put this revision together for Arun Kumar who needs to export data from the body of certain messages. The script writes the data to an existing spreadsheet and avoids exporting items twice by tagging processed items with a category.

Arun will use the instructions from the original post to add this code to Outlook.

'On the next line, edit the path to the workbook the data will be exported to
Const WORKBOOK_NAME = "c:\users\arun\documents\testarea\arun_kumar.xlsx"
'On the next line, edit the name of the category the script will assign to items that it has processed
Const CATEGORY_NAME = "Arun"
'On the next line, edit the path to the root folder the attachments are to be saved under
Const ROOT_DIR = "D:\Work"
Const MACRO_NAME = "Export Messages to Excel (Rev 48)"

Private Sub ExportMessagesToExcel()
    Dim olkFld As Object, _
        olkRng As Object, _
        olkMsg As Object, _
        olkAtt As Object, _
        objFSO As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        intVersion As Integer, _
        strTemp As String, _
        arrLines As Variant, _
        varLine As Variant, _
        strDat As String, _
        arrTmp As Variant, _
        datBeg As Date, _
        datEnd As Date, _
        strExt As String, _
        strDir As String, _
        strOrd As String
    'Write messages to spreadsheet
    strDat = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
    arrTmp = Split(strDat, "to")
    datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & " 12:00am"
    datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & " 11:59pm"
    Set olkFld = Application.ActiveExplorer.CurrentFolder
    Set olkRng = olkFld.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
    If olkRng.Count > 0 Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Open(WORKBOOK_NAME)
        Set excWks = excWkb.Worksheets(1)
        lngRow = excWks.UsedRange.rows.Count + 1
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        For Each olkMsg In olkRng
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                If Not IsTagged(olkMsg.Categories) Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(lngRow, 1) = olkMsg.ReceivedTime
                    excWks.Cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion)
                    arrLines = Split(olkMsg.Body, vbCrLf)
                    For Each varLine In arrLines
                        strTemp = Trim(varLine)
                        If Left(strTemp, 10) = "Order No: " Then
                            strOrd = Mid(strTemp, 11)
                            excWks.Cells(lngRow, 3) = Mid(strTemp, 11)
                        Else
                            If Left(strTemp, 9) = "Loan No: " Then
                                excWks.Cells(lngRow, 4) = Mid(strTemp, 10)
                            Else
                                If Left(strTemp, 15) = "Borrower Name: " Then
                                    excWks.Cells(lngRow, 5) = Mid(strTemp, 16)
                                    bolComments = True
                                Else
                                    If Left(strTemp, 18) = "Property Address: " Then
                                        excWks.Cells(lngRow, 6) = Mid(strTemp, 19)
                                    Else
                                        If Left(strTemp, 16) = "Vendor Product: " Then
                                            excWks.Cells(lngRow, 7) = Mid(strTemp, 17)
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    Next
                    'Save the Word attachment, if there is one
                    For Each olkAtt In olkMsg.Attachments
                        strExt = objFSO.GetExtensionName(olkAtt.Filename)
                        Select Case strExt
                            Case "doc", "docx"
                                strDir = ROOT_DIR & "\" & MonthName(Month(olkMsg.ReceivedTime), True)
                                If Not objFSO.FolderExists(strDir) Then objFSO.CreateFolder strDir
                                strDir = strDir & "\" & StrZero(Day(olkMsg.ReceivedTime), 2)
                                If Not objFSO.FolderExists(strDir) Then objFSO.CreateFolder strDir
                                strDir = strDir & "\" & strOrd
                                If Not objFSO.FolderExists(strDir) Then objFSO.CreateFolder strDir
                                olkAtt.SaveAsFile strDir & "\" & olkAtt.Filename
                        End Select
                    Next
                    'Tag the message so it isn't processed a second time
                    If Len(olkMsg.Categories) = 0 Then
                        olkMsg.Categories = CATEGORY_NAME
                    Else
                        olkMsg.Categories = olkMsg.Categories & "," & CATEGORY_NAME
                    End If
                    olkMsg.Save
                    lngRow = lngRow + 1
                    lngCnt = lngCnt + 1
                End If
            End If
        Next
        Set olkMsg = Nothing
        excWks.Columns("A:G").AutoFit
        excWkb.Close True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
    Else
        MsgBox "Operation cancelled.  There are no items in the range " & datBeg & " - " & datEnd, vbInformation + vbOKOnly, MACRO_NAME
    End If
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

Private Function IsTagged(strCats As String) As Boolean
    Dim arrCats As Variant, varItem As Variant
    arrCats = Split(strCats, ",")
    For Each varItem In arrCats
        If varItem = CATEGORY_NAME Then
            IsTagged = True
            Exit For
        End If
    Next
End Function

Private Function StrZero(varNumber As Variant, intLength As Integer) As String
    ' Purpose: Pad a number with zeroes to the given length and return it as a string.'
    ' Written: 4/24/2009'
    ' Author:  TechnicLee'
    ' Outlook: All versions'
    Dim intItemLength As Integer
    If IsNumeric(varNumber) Then
        intItemLength = Len(CStr(Int(varNumber)))
        If intItemLength < intLength Then
            StrZero = String(intLength - intItemLength, "0") & varNumber
        Else
            StrZero = varNumber
        End If
    Else
        StrZero = varNumber
    End If
End Function 

I put this revision together for Anders who needs to export all the email addresses from the bodies of certain messages. The script writes the sender’s address to column A and the harvested addresses to separate columns beginning in column B. The solution saves the data from each run to a new spreadsheet.

Anders will use the instructions from the original post to add this code to Outlook.

Sub ExportAddresses()
    Const MACRO_NAME = "Export Addresses"
    Dim olkItm As Object, strBuf As String, arrAdr As Variant, varAdr As Variant, lngRow As Long, lngCol As Long, strFil As String, intVer As Integer
    Dim excApp As Object, excWkb As Object, excWks As Object
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFil = "" Then
        MsgBox "You must enter the name of a file to save the output to.  Processing cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        lngRow = 1
        For Each olkItm In Application.ActiveExplorer.CurrentFolder.Items
            If olkItm.Class = olMail Then
                strBuf = FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b")
                If strBuf <> "Not found" Then
                    excWks.Cells(lngRow, 1) = GetSMTPAddress(olkItm, intVer)
                    lngCol = 2
                    arrAdr = Split(strBuf, "|")
                    For Each varAdr In arrAdr
                        excWks.Cells(lngRow, lngCol) = varAdr
                        lngCol = lngCol + 1
                    Next
                    excWks.Columns("A:" & NumberToLetter(lngCol)).AutoFit
                    lngRow = lngRow + 1
                End If
            End If
        Next
        Set excWks = Nothing
        excWkb.SaveAs strFil
        excWkb.Close False
        Set excWkb = Nothing
        Set excApp = Nothing
        Set olkItm = Nothing
        MsgBox "Processing complete.", vbInformation + vbOKOnly, MACRO_NAME
    End If
End Sub

Private 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 = True
        .Global = True
        .Pattern = strFind
        Set colMatches = .Execute(strText)
    End With
    If colMatches.Count > 0 Then
        For Each objMatch In colMatches
            FindString = FindString & objMatch.Value & "|"
        Next
        FindString = Left(FindString, Len(FindString) - 1)
    Else
        FindString = "Not found"
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
    Set objMatch = Nothing
End Function

Private Function NumberToLetter(ByVal intNumber As Integer) As String
    Dim intTmp As Integer
    If intNumber <= 26 Then
        NumberToLetter = Chr(64 + intNumber)
    Else
        NumberToLetter = Chr(64 + Int(intNumber / 26)) & Chr(64 + intNumber Mod 26)
    End If
End Function

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Private Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Private Function SMTP2007(olkMsg As Outlook.MailItem) 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

2,549 comments on “Exporting Outlook Messages to Excel

  1. Hi David.

    It’s a bit of a strange set up, actually. When signed into my work email, I have my own inbox and the “Support” inbox, which is filled with emails from our support@ email address, which may complicate things. The subfolder that I’m looking to take the emails from is here under another subfolder. The layout of my Outlook desktop is my own inbox and subfolders, then
    Support
    Inbox
    1. Daily Backups
    Successful
    Other Backups
    Terastations

    The emails that I’m trying to get are in the Terastation subfolder, which is a subfolder of Daily Backups, within the Support Inbox. I don’t know if it would be possible to do it this way.

    Thanks for all of your help so far, once again.

    • Hi, Sam.

      Add this code to what you already have. Please add it at the bottom of the existing code.

      Function OpenOutlookFolder(strFolderPath)
          Dim arrFolders, varFolder, bolBeyondRoot
          On Error Resume Next
          If strFolderPath = "" Then
              Set OpenOutlookFolder = Nothing
          Else
              Do While Left(strFolderPath, 1) = "\"
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
              Loop
              arrFolders = Split(strFolderPath, "\")
              For Each varFolder In arrFolders
                  Select Case bolBeyondRoot
                      Case False
                          Set OpenOutlookFolder = olkSes.Folders(varFolder)
                          bolBeyondRoot = True
                      Case True
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                  End Select
                  If Err.Number <> 0 Then
                      Set OpenOutlookFolder = Nothing
                      Exit For
                  End If
              Next
          End If
          On Error GoTo 0
      End Function
      

      Once you’ve done that, please change this line of code

      Set olkFld = olkSes.GetDefaultFolder(olFolderInbox)
      

      to

      Set olkFld = OpenOutlookFolder("support@company.com\Inbox\Daily Backups\Terastations")
      

      where “support@company.com” is the support email address.

  2. Hi David,

    This is a great help to everyone. Could you please help me in my case. I want to extract the email attachments data then Subject, From, To and Forwarded Time and then the Second email’s attachments data followed by Subject,From, To and Forwarded Time Then third email and so on in one excel sheet. Provided excel sheet already exists and user will select the processing folder from Outlook.

    Thanks for your help in advance.

    • Hi, Amit.

      Thanks!

      What does “email attachment data” mean in this context? If it means that you want to extract data from each attachment, then what types of attachments would a solution need to be prepared to handle? If instead it means that you want to save data abut each attachment (e.g. filename, size), then that’s doable. I also need to know what you mean when you say “Forwarded Time”. Outlook does not keep track of when attachments are forwarded. It doesn’t even keep track of when messages are forwarded, at least not in an obvious or reliable way. Outlook keeps track of something called “last verb used”. In other words, Outlook keeps track of the date/time you perform actions such as “reply” or “forward” on a message. It’s not reliable though. You can see this for yourself with this simple set of actions. Open a message and select reply or forward. When the reply/forward opens, click cancel. Now look at the original message and you’ll see that it says you replied/forwarded even though you never sent that reply/forward. All Outlook did was record that you selected an action, the last verb used, and the date/time you made that selection. A solution can export that date/time, but it isn’t a reliable indicator that the reply/forward was actually sent.

    • Hi David,

      Greetings. The email attachment means that there are 100 excel files that I receive daily. I want the contents of that excel file in one excel sheet including the subject, sender, time. Then it should move on to the next xlsx attachment.

      Please revert if any other information is needed.

      Thanks.

    • Hi, Amit.

      Got it. You want to combine multiple spreadsheets into a single workbook. Please tell me more about each of the spreadsheets. Is each one a single page or multiple pages? Do you want everything on the page(s) or only certain cells? In other words, I need to know exactly what to copy out of each of the received sheets. I also need to know exactly how you want the data copied into the target workbook. Please give me as much detail as you can.

    • Hi David,

      Greetings!!!. There will be only one sheet in each workbook. Currently i am using 3 different macros. 1. To extract Sender, To, Received time. 2. The macro will download all the attachments to a folder (Eg. 50 Workbooks having 50 Sheets copied to a Folder). 3. The macro will combine all the worksheets from different workbooks into one Master sheet. What i want to do is:

      Column A Column B Column C Column D Column E
      Subject Time Sender Attachments Count To

      Just below this will be the data from attachment. Then it should go to second email extract the same details and paste it in the next empty row.

      Please let me know if you would like me to send all the three macro codes of mine. If that you think is feasible or a dump excel file.

      Thanks again for your help.

      Regards,
      Amit.

    • Hi, Amit.

      Sorry to be so dense, but I’m still not clear on what you want from each attachment. I understand that each attachment is an Excel workbook with a single sheet. Do you want everything from each sheet? If so, then are all the sheets the same size (i.e. the same number of rows and columns) or do they vary in size? If they are all the same size, then I can code in the starting/ending row/column. If they are not all the same size, then I’ll need to add code that finds the starting/ending row/column.

    • Hi David,

      Sorry i forgot to mention one more point, i want to give a date range to extract the data from email. Can it be possible to control this through one macro and in the format that i mentioned?

      Thanks as usual.

    • Hi, Amit.

      What date range are we talking about? Message date, attachment date, or a date in the data in the attachment?

    • Hi David,

      Not a problem. I think i am not giving the correct information. Yes i want everything from that sheet.
      No the rows and columns can be different not all the same size. The date i am talking about is that the
      code will only run on those emails that are within the date range that i give. For example i only want that
      code will extract the details from 02/23/2015 to 02/25/2015 on all the emails that are in selected folder.

      I am attaching my code below. The code will ask to select a folder from email but it did not ask the date range.

      Option Explicit
      Public gblStopProcessing As Boolean
      Sub ParseBlockingSessionsEmailPartOne()
      Dim wb As Workbook
      Dim ws As Worksheet
      Dim objFolder As Object
      Dim objNSpace As Object
      Dim objOutlook As Outlook.Application
      Dim lngAuditRecord As Long
      Dim lngCount As Long
      Dim lngTotalItems As Long
      Dim lngTotalRecords As Long
      Dim i As Integer
      Dim EmailCount As Integer
      
      On Error GoTo HandleError
      
      Sheets("Merge Data").Select
      
      Set wb = ThisWorkbook
      lngAuditRecord = 1
      lngTotalRecords = 0
      
      Application.ScreenUpdating = False
      Set objOutlook = CreateObject("Outlook.Application")
      Set objNSpace = objOutlook.GetNamespace("MAPI")
      
      Set objFolder = objNSpace.PickFolder
      
      If objFolder Is Nothing Then
      gblStopProcessing = True
      MsgBox "Processing cancelled"
      Exit Sub
      End If
      '
      lngTotalItems = objFolder.Items.Count
      If lngTotalItems = 0 Then
      MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
      gblStopProcessing = True
      GoTo HandleExit
      End If
      If lngTotalItems &gt; 0 Then
      On Error Resume Next
      Application.DisplayAlerts = False
      wb.Worksheets("Merge Data").Delete
      
      Application.DisplayAlerts = True
      On Error GoTo HandleError
      wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
      Set ws = ActiveSheet
      ws.Name = "Merge Data"
      
      
      ws.Cells(1, 1) = "Received"
      ws.Cells(1, 2) = "Subject"
      ws.Cells(1, 3) = "Sender Name"
      ws.Cells(1, 4) = "To"
      ws.Cells(1, 5) = "CC"
      ws.Cells(1, 6) = "Attachments Count"
      'ws.Cells(lngAuditRecord, 3) = "Subject"
      'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
      'ws.Cells(lngAuditRecord, 4) = "Sender Name"
      'ws.Cells(lngAuditRecord, 5) = "Sender Email"
      ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
      Selection.EntireRow.Font.Bold = True
      Selection.HorizontalAlignment = xlCenter
      
      
      For lngCount = 1 To lngTotalItems
      Application.StatusBar = "Reading message " &amp; lngCount &amp; " of " &amp; lngTotalItems
      i = 0
      
      While i &lt; lngTotalItems
      i = i + 1
      If i Mod 50 = 0 Then Application.StatusBar = &quot;Reading email messages &quot; &amp; Format(i / lngTotalItems, &quot;0%&quot;) &amp; &quot;...&quot;
      With objFolder.Items(i)
      Cells(i + 1, 1).Formula = .ReceivedTime
      Cells(i + 1, 2).Formula = .Subject
      Cells(i + 1, 3).Formula = .SenderName
      Cells(i + 1, 4).Formula = .To
      Cells(i + 1, 5).Formula = .CC
      Cells(i + 1, 6).Formula = .Attachments.Count
      'Cells(i + 1, 6).Formula = .Attachments.Names
      'Cells(i + 1, 5).Formula = .Body
      
      'Cells(i + 1, 6).Formula = .SenderEmailAddress
      'Cells(i + 1, 4).Formula = .SendTime
      
      End With
      Wend
      
      ws.Activate
      Next lngCount
      lngTotalRecords = lngCount
      
      
      Columns(&quot;B:B&quot;).Select
      Selection.ColumnWidth = 255
      Cells.Select
      Selection.Columns.AutoFit
      Selection.Rows.AutoFit
      With Selection
      .VerticalAlignment = xlTop
      End With
      Range(&quot;A1&quot;).Select
      End If
      
      If lngTotalRecords = 0 Then
      MsgBox &quot;No records were found for import&quot;, vbOKOnly + vbCritical, &quot;Error - no records found&quot;
      gblStopProcessing = True
      GoTo HandleExit
      End If
      '
      With Selection
      Cells.Select
      .VerticalAlignment = xlTop
      .WrapText = True
      End With
      Range(&quot;A1&quot;).Select
      '
      HandleExit:
      On Error Resume Next
      Application.ScreenUpdating = True
      Set objNSpace = Nothing
      Set objFolder = Nothing
      Set objOutlook = Nothing
      Set ws = Nothing
      Set wb = Nothing
      If Not gblStopProcessing Then
      MsgBox &quot;Processing completed&quot; &amp; vbCrLf &amp; vbCrLf &amp; _
      &quot;Please check results&quot;, vbOKOnly + vbInformation, &quot;Information&quot;
      End If
      
      Exit Sub
      
      HandleError:
      MsgBox Err.Number &amp; vbCrLf &amp; Err.Description
      gblStopProcessing = True
      Resume HandleExit
      End Sub
      
    • Hi, Amit.

      I’ve added code to your code that handles the date range filter. Please try it out and make sure it works the way you want it to. If it works properly, then we’ll tackle the attachment portion.

      Option Explicit
      Const MACRO_NAME = "Parse Blocking Sessions Email Part One"
      
      Public gblStopProcessing As Boolean
      
      Sub ParseBlockingSessionsEmailPartOne()
          Dim wb As Workbook
          Dim ws As Worksheet
          Dim objFilter As Object
          Dim objFolder As Object
          Dim objNSpace As Object
          Dim objOutlook As Object
          Dim lngAuditRecord As Long
          Dim lngCount As Long
          Dim lngTotalItems As Long
          Dim lngTotalRecords As Long
          Dim i As Integer
          Dim EmailCount As Integer
          Dim datBeg As Date, datEnd As Date
          Dim strDateRange As String
          Dim arrTemp As Variant
           
          On Error GoTo HandleError
           
          Sheets("Merge Data").Select
           
          Set wb = ThisWorkbook
          lngAuditRecord = 1
          lngTotalRecords = 0
           
          Application.ScreenUpdating = False
          Set objOutlook = CreateObject("Outlook.Application")
          Set objNSpace = objOutlook.GetNamespace("MAPI")
           
          Set objFolder = objNSpace.PickFolder
           
          If objFolder Is Nothing Then
              gblStopProcessing = True
              MsgBox "Processing cancelled"
              Exit Sub
          End If
          '
          strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
          arrTemp = Split(strDateRange, "to")
          datBeg = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
          datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
          Set objFilter = objFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
          lngTotalItems = objFilter.Count
          If lngTotalItems = 0 Then
              MsgBox "The Outlook folder does not contain andy email messages that fall within the specified date range", vbOKOnly + vbCritical, "Error - Nothing in Date Range"
              gblStopProcessing = True
              GoTo HandleExit
          End If
          If lngTotalItems > 0 Then
              On Error Resume Next
              Application.DisplayAlerts = False
              wb.Worksheets("Merge Data").Delete
               
              Application.DisplayAlerts = True
              On Error GoTo HandleError
              wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
              Set ws = ActiveSheet
              ws.Name = "Merge Data"
               
              ws.Cells(1, 1) = "Received"
              ws.Cells(1, 2) = "Subject"
              ws.Cells(1, 3) = "Sender Name"
              ws.Cells(1, 4) = "To"
              ws.Cells(1, 5) = "CC"
              ws.Cells(1, 6) = "Attachments Count"
              ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
              Selection.EntireRow.Font.Bold = True
              Selection.HorizontalAlignment = xlCenter
               
              For lngCount = 1 To lngTotalItems
                  Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
                  With objFilter(lngCount)
                      Cells(lngCount + 1, 1).Formula = .ReceivedTime
                      Cells(lngCount + 1, 2).Formula = .Subject
                      Cells(lngCount + 1, 3).Formula = .SenderName
                      Cells(lngCount + 1, 4).Formula = .To
                      Cells(lngCount + 1, 5).Formula = .CC
                      Cells(lngCount + 1, 6).Formula = .Attachments.Count
                  End With
                  ws.Activate
              Next lngCount
              lngTotalRecords = lngCount
               
               
              Columns("B:B").Select
              Selection.ColumnWidth = 255
              Cells.Select
              Selection.Columns.AutoFit
              Selection.Rows.AutoFit
              With Selection
                  .VerticalAlignment = xlTop
              End With
              Range("A1").Select
          End If
           
          If lngTotalRecords = 0 Then
              MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
              gblStopProcessing = True
              GoTo HandleExit
          End If
          '
          With Selection
              Cells.Select
              .VerticalAlignment = xlTop
              .WrapText = True
          End With
          Range("A1").Select
          '
      HandleExit:
          On Error Resume Next
          Application.ScreenUpdating = True
          Set objNSpace = Nothing
          Set objFilter = Nothing
          Set objFolder = Nothing
          Set objOutlook = Nothing
          Set ws = Nothing
          Set wb = Nothing
          If Not gblStopProcessing Then
              MsgBox "Processing completed" & vbCrLf & vbCrLf & _
              "Please check results", vbOKOnly + vbInformation, "Information"
          End If
          Exit Sub
           
      HandleError:
          MsgBox Err.Number & vbCrLf & Err.Description
          gblStopProcessing = True
          Resume HandleExit
      End Sub
      
    • Hi, uni1.

      I’m assuming that you want to change the date format in the spreadsheet. If so, then change this line

      excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
      

      to

      excWks.Cells(intRow, 2) = Format(olkMsg.ReceivedTime, "dd/mm/yyyy h:m AMPM")
      
  3. Hi David

    This is great, thank you very much. One question, though, can I set the tasks through Outlook as appointments? Other than that, the only change that I will try to make is that the emails are coming from a subfolder within a sub folder, so I will try to fix that.

    Thank you very much.

    • Hi, Sam.

      Yes, I can modify the solution so it’s triggered by an Outlook appointment. That type of solution is not as reliable though as using Windows Task Scheduler. An Outlook based solution also requires that you be logged in and that Outlook be open and running. Are the sub-folders under the Inbox or some other folder? If they are under the Inbox, then the code for getting a sub-folder is a little simpler. If the sub-folder is under some other folder, then I’ll need to add another function to retrieve the folder.

  4. Hi David,

    I’m finding this post to be extremely useful but was wondering if you could help me with the following. When running the standard code you give everything works fine. However I’m in a similar situation as the person in revision 43 and when using that code I get a runtime error. It also says “automation error” and “unspecified error” The line that the VB editor points to is line 53 and reads “Set objIE = CreateObject(“InternetExplorer.Application”)”

    Any idea whats happening? I understand if you don’t have time but help would really be appreciated.

    Nico

    • Hi David,

      After a lot of headbanging I finally figured out what was going on.

      Excel creates a new activeX instance every time you run the line:
      Set IE = CreateObject(“InternetExplorer.Application”)

      The references stick around even after you restart excel. After a couple dozen pile up, excel runs out of memory to make more

      Simply closing iexplorer process from the task manager fixes the problem.

      Adding IE.Quit should solve

    • Hi, Nico.

      Others have reported that issue too. It’s interesting that some folks encounter this issue while others don’t I’ve not been able to figure out why. Adding objIE.Quit may solve the problem, but only if IE isn’t already open. If it is, then in my experience objIE.Quit won’t help. Another solution is to add a command that kills the IE task altogether. That always works, but has the side-effect of closing all open IE windows, including those that are not related to this script.

  5. Hello,

    I´m working on revision 7 of your outlook to excel export macro and I need your help to customize it, if possible.

    I need the messages not to repeat themselves, only receive the new ones and overwrite the old file, is it possible?

    I also need to receive date time and body of the message in different columns.

    Best Regards

    • Hi, Helder.

      If I’ve understood correctly, then this should do it. Please follow the instructions from my original post to add the code to Outlook.

      'On the next line edit the path to the spreadsheet you want to export to
      Const WORKBOOK_PATH = "c:\Users\David\Documents\Sample.xlsx"
      Const MACRO_NAME = "Export Messages to Excel (Rev Helder)"
      Const xlExclusive = 3
       
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              intRow As Integer, _
              intExp As Integer, _
              intVersion As Integer
          intVersion = GetOutlookVersion()
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Add
          Set excWks = excWkb.Worksheets(1)
          intRow = 2
          excWks.Cells(1, 1) = "Subject"
          excWks.Cells(1, 2) = "Received"
          excWks.Cells(1, 3) = "Sender"
          excWks.Cells(1, 4) = "Message"
          'Write messages to spreadsheet
          For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
              'Only export messages, not receipts or appointment requests, etc.
              If olkMsg.Class = olMail Then
                  If InStr(1, olkMsg.Categories, "Processed") = 0 Then
                      'Add a row for each field in the message you want to export
                      excWks.Cells(intRow, 1) = olkMsg.Subject
                      excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                      excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                      excWks.Cells(intRow, 4) = olkMsg.Body
                      intRow = intRow + 1
                      intExp = intExp + 1
                      If Len(olkMsg.Categories) = 0 Then
                          olkMsg.Categories = "Processed"
                      Else
                          olkMsg.Categories = olkMsg.Categories & ", Processed"
                      End If
                      olkMsg.Save
                  End If
              End If
          Next
          Set olkMsg = Nothing
          excWkb.SaveAs FILENAME:=WORKBOOK_PATH, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
          excWkb.Close False
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          MsgBox "Process complete.  A total of " & intExp & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
      End Sub
       
      Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
          Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
          On Error Resume Next
          Select Case intOutlookVersion
              Case Is < 14
                  If Item.SenderEmailType = "EX" Then
                      GetSMTPAddress = SMTP2007(Item)
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
              Case Else
                  Set olkSnd = Item.Sender
                  If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                      Set olkEnt = olkSnd.GetExchangeUser
                      GetSMTPAddress = olkEnt.PrimarySmtpAddress
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
          End Select
          On Error GoTo 0
          Set olkPrp = Nothing
          Set olkSnd = Nothing
          Set olkEnt = Nothing
      End Function
       
      Function GetOutlookVersion() As Integer
          Dim arrVer As Variant
          arrVer = Split(Outlook.Version, ".")
          GetOutlookVersion = arrVer(0)
      End Function
       
      Function SMTP2007(olkMsg As Outlook.MailItem) 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
      
  6. Hello, thank you for this, it has been extremely useful. Is it possible to combine both Rev 3 and Rev 4, so that all items including those in subfolders in a specified date range, are exported?

    Thanks again.

    • Good morning, Dorothy.

      You’re welcome. I’m glad the solution has been useful.

      Yes, that’s possible. Here is the code. Please follow the instructions from the original post to add this code to Outlook.

      Const MACRO_NAME = "Export Messages to Excel (Rev Dorothy)"
       
      Dim excApp As Object, _
          excWkb As Object, _
          excWks As Object, _
          intVer As Integer, _
          lngCnt As Long, _
          lngRow As Long, _
          datBeg As Date, _
          datEnd As Date
       
      Sub ExportMessagesToExcel()
          Dim strFilename As String, strDateRange As String, arrTemp As Variant
          strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
          If strFilename <> "" Then
              strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
              arrTemp = Split(strDateRange, "to")
              datBeg = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
              datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
              lngCnt = 0
              intVer = GetOutlookVersion()
              Set excApp = CreateObject("Excel.Application")
              Set excWkb = excApp.Workbooks.Add()
              Set excWks = excWkb.ActiveSheet
              'Write Excel Column Headers
              With excWks
                  .Cells(1, 1) = "Subject"
                  .Cells(1, 2) = "Received"
                  .Cells(1, 3) = "Sender"
              End With
              lngRow = 2
              ProcessFolder Application.ActiveExplorer.CurrentFolder
              excWkb.SaveAs strFilename
              excWkb.Close False
              Set excWks = Nothing
              Set excWkb = Nothing
              excApp.Quit
              Set excApp = Nothing
              MsgBox "Process complete.  I exported a total of " & lngCnt & " messages.", vbInformation + vbOKOnly, MACRO_NAME
          Else
              MsgBox "You did not enter a filename.  Export cancelled.", vbExclamation + vbOKOnly, MACRO_NAME
          End If
      End Sub
       
      Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
          Dim olkLst As Object, _
              olkMsg As Object, _
              olkSub As Object
          If olkFld.DefaultItemType = olMailItem Then
              Set olkLst = olkFld.Items.Restrict("[ReceivedTime] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
              'Write messages to spreadsheet
              For Each olkMsg In olkLst
                  'Only export messages, not receipts or appointment requests, etc.
                  If olkMsg.Class = olMail Then
                      'Add a row for each field in the message you want to export
                      excWks.Cells(intRow, 1) = olkMsg.Subject
                      excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                      excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
                      lngRow = lngRow + 1
                      lngCnt = lngCnt + 1
                  End If
              Next
              Set olkMsg = Nothing
          End If
          For Each olkSub In olkFld.Folders
              ProcessFolder olkSub
          Next
          Set olkSub = Nothing
      End Sub
       
      Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
          Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
          On Error Resume Next
          Select Case intOutlookVersion
              Case Is < 14
                  If Item.SenderEmailType = "EX" Then
                      GetSMTPAddress = SMTP2007(Item)
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
              Case Else
                  Set olkSnd = Item.Sender
                  If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                      Set olkEnt = olkSnd.GetExchangeUser
                      GetSMTPAddress = olkEnt.PrimarySmtpAddress
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
          End Select
          On Error GoTo 0
          Set olkPrp = Nothing
          Set olkSnd = Nothing
          Set olkEnt = Nothing
      End Function
       
      Function GetOutlookVersion() As Integer
          Dim arrVer As Variant
          arrVer = Split(Outlook.Version, ".")
          GetOutlookVersion = arrVer(0)
      End Function
       
      Function SMTP2007(olkMsg As Outlook.MailItem) 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
      
  7. Hi David – this code is awesome! Thank you. Is there a simple edit I can make to Revision 1 above to also retrieve the SMTP recipient email address into the Excel report? Thank you again.

    • Hi, Dan.

      Thanks!

      Do you want the SMTP address of each addressee (i.e. each recipient) or just for the account you received the message through?

    • Thank you, David. Just the SMTP email address of the “To” addressee on the email, whether than is one individual or many. I don’t need to have it for CCs or BCCs. Thank you very much.

    • Dan,

      Please replace the subroutine ExportMessagesToExcel with this version.

      Sub ExportMessagesToExcel(strFilename As String, strFolderPath As String)
          Dim olkMsg As Object, _
              olkFld As Object, _
              olkRec As Outlook.Recipient, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              intRow As Integer, _
              intVersion As Integer, _
              strAddresses As String
          If strFilename <> "" Then
              If strFolderPath <> "" Then
                  Set olkFld = OpenOutlookFolder(strFolderPath)
                  If TypeName(olkFld) <> "Nothing" Then
                      intVersion = GetOutlookVersion()
                      Set excApp = CreateObject("Excel.Application")
                      Set excWkb = excApp.Workbooks.Add()
                      Set excWks = excWkb.ActiveSheet
                      'Write Excel Column Headers
                      With excWks
                          .Cells(1, 1) = "Subject"
                          .Cells(1, 2) = "Received"
                          .Cells(1, 3) = "Sender"
                          .Cells(1, 4) = "Recipients"
                      End With
                      intRow = 2
                      'Write messages to spreadsheet
                      For Each olkMsg In olkFld.Items
                          'Only export messages, not receipts or appointment requests, etc.
                          If olkMsg.Class = olMail Then
                              strAddresses = ""
                              For Each olkRec In olkMsg.Recipients
                                  If olkRec.Type = olTo Then
                                      strAddresses = strAddresses & GetSMTP(olkRec) & ", "
                                  End If
                              Next
                              If Len(strAddresses) > 0 Then strAddresses = Left(strAddresses, Len(strAddresses) - 2)
                              'Add a row for each field in the message you want to export
                              excWks.Cells(intRow, 1) = olkMsg.Subject
                              excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                              excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                              excWks.Cells(intRow, 4) = strAddresses
                              intRow = intRow + 1
                          End If
                      Next
                      Set olkMsg = Nothing
                      excWkb.SaveAs strFilename
                      excWkb.Close
                  Else
                      MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
                  End If
              Else
                  MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
              End If
          Else
              MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
          End If
          Set olkMsg = Nothing
          Set olkFld = Nothing
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
      

      And add this code.

      Function GetSMTP(olkRec As Outlook.Recipient) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkRec.PropertyAccessor
          GetSMTP = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      

      Leave the rest of the code as is.

  8. Hello David,

    Today I use the code below to export messages to excel, but sometimes I have an error and the macro didn’t working. Maybe because the macro create a duplicate folder and file on this line: Set objFSO = CreateObject(“Scripting.FileSystemObject”). Is it possible to change the code to resume and go to next when this happen?

    Sub RunExportMessagesToExcel2()
        '--&gt; Declare some variables
        Dim strWkb As String, strDateRange As String, arrTemp As Variant
        If MsgBox("Deseja efetuar o backup ? Lembre-se de fechar o arquivo excel de backup antes de clicar em OK!", vbInformation + vbOKCancel, MACRO_NAME) = vbCancel Then
        Cancel = True
        Else
        strWkb = WORKBOOK_PATH
        If strWkb  "" Then
            strDateRange = InputBox("Enter the date range of the messages to export in the form ""dd/mm/yyyy to dd/mm/yyyy""", MACRO_NAME, Date &amp; " to " &amp; Date)
            arrTemp = Split(strDateRange, "to")
            datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) &amp; " 12:00am"
            datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) &amp; " 11:59pm"
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            'Connect to Excel
            Set excApp = CreateObject("Excel.Application")
            If objFSO.FileExists(strWkb) Then
                        Set excWkb = excApp.Workbooks.Open(strWkb)
                        Set excWks = excWkb.Worksheets(SHEET_NAME)
                        lngRow = excWks.UsedRange.Rows.Count + 1
                    Else
                        Set excWkb = excApp.Workbooks.Add()
                        Set excWks = excWkb.Worksheets(1)
                        lngRow = 2
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Date"
                .Cells(1, 2) = "Time"
                .Cells(1, 3) = "Subject"
                .Cells(1, 4) = "To"
                .Cells(1, 5) = "From"
                .Cells(1, 6) = "Attachments"
                .Cells(1, 7) = "ID"
                .Cells(1, 8) = "Link"
                .Cells(1, 9) = "CC"
                .Cells(1, 10) = "Body"
                .Cells(1, 11) = "Folder"
            End With
            bolNew = True
                    End If
            'On the next line change "Store" to the name of the store the search folder is in and "Folder" to the name of the search folder you want
            ExportMessagesToExcel OpenOutlookSearchFolder(STORE_NAME, FOLDER_NAME)
            excWks.Columns("A:B").AutoFit
            excWks.Columns("J:J").WrapText = False
            excWkb.SaveAs strWkb
            excWkb.Close
            Set excWks = Nothing
            Set excWkb = Nothing
            Set excApp = Nothing
            Set objFSO = Nothing
            MsgBox "Process complete.  A total of " &amp; lngCnt &amp; " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
        Else
            MsgBox "Operation canceled.", vbInformation + vbOKOnly, MACRO_NAME
        End If
         End If
         Exit Sub
    End Sub
      
    Private Sub ExportMessagesToExcel(olkFol As Outlook.MAPIFolder)
        '--&gt; Declare some variables
        Dim olkMsg As Object, _
            olkAtt As Object, _
            olkCol As Object, _
            objFol As Object, _
            olkLst As Object, _
            strAtt As String
        'Process the current folder and write its messages to the spreadsheet
        Set olkCol = olkFol.Items
        olkCol.Sort "ReceivedTime"
        Set olkLst = olkCol.Restrict("[ReceivedTime] &gt;= '" &amp; Format(datStart, "ddddd h:nn AMPM") &amp; "'" &amp; " AND [ReceivedTime]  0 Then strAtt = Left(strAtt, Len(strAtt) - 2)
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkMsg.ReceivedTime
                excWks.Cells(lngRow, 2) = Format(olkMsg.ReceivedTime, "hh:nn")
                excWks.Cells(lngRow, 3) = olkMsg.Subject
                excWks.Cells(lngRow, 4) = olkMsg.To
                excWks.Cells(lngRow, 5) = olkMsg.SenderName
                excWks.Cells(lngRow, 6) = strAtt
                excWks.Cells(lngRow, 7) = olkMsg.EntryID
                excWks.Cells(lngRow, 9) = olkMsg.CC
                excWks.Cells(lngRow, 10) = olkMsg.Body
                excWks.Cells(lngRow, 11) = olkMsg.Parent.FolderPath
                excWks.Hyperlinks.Add Anchor:=excWks.Range("H" &amp; lngRow, "H" &amp; lngRow), Address:="file://" &amp; objFol.Path, TextToDisplay:="View Original Items"
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
                Set olkAtt = Nothing
            End If
            DoEvents
        Next
        Set olkCol = Nothing
        Set olkLst = Nothing
        Set olkMsg = Nothing
        Set objFol = Nothing
    End Sub
      
    Private Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
        ' Purpose: Determines if an attachment is a hidden attachment.
        Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
        Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
        On Error Resume Next
        Set olkPA = olkAtt.PropertyAccessor
        varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
        IsHiddenAttachment = (varTemp  "")
        On Error GoTo 0
        Set olkPA = Nothing
    End Function
     
    Public Function OpenOutlookSearchFolder(strStore As String, strFolder As String) As Outlook.MAPIFolder
        ' Purpose: Opens an Outlook search folder by name.'
        ' Outlook: All versions'
        Dim olkStore As Object, _
            olkFolders As Object
        On Error Resume Next
        If (strStore = "") Or (strFolder = "") Then
            Set OpenOutlookSearchFolder = Nothing
        Else
            Set olkStore = Outlook.Session.Stores.Item(strStore)
            If TypeName(olkStore) = "Nothing" Then
                OpenOutlookSearchFolder = Nothing
            Else
                Set olkFolders = olkStore.GetSearchFolders
                Set OpenOutlookSearchFolder = olkFolders.Item(strFolder)
                If TypeName(OpenOutlookSearchFolder) = "Nothing" Then
                    OpenOutlookSearchFolder = Nothing
                End If
            End If
        End If
        On Error GoTo 0
    End Function
    
    • Hi, Vagston.

      The line

      Set objFSO = CreateObject(“Scripting.FileSystemObject”)
      

      doesn’t create a folder. It creates an object that the code uses to perform file operations. It’s extremely unlikely that it’s the cause of an error. What is the error message you’re getting and when it occurs what line of the code does it highlight?

    • Hi David,

      You are right. The error is on this line:
      Set objFol = objFSO.CreateFolder(ROOT_PATH & “\” & olkMsg.EntryID)

      Run-time error ’58′:
      File already exists

      As i said, this happen when I export messages to excel with the same date.

    • Hi, Vagston.

      EntryID’s are unique to a folder. Based on the error, you must be exporting the contents of the same Outlook folder multiple times. is that by design? If so, why? That aside, I can modify the code to check to see if the file system folder already exists and only create it if it doesn’t. But, if the file system folder does exist (i.e. you’ve exported that message before), then the code may encounter other problems since the exported message and attachments will already exist too.

    • David,
      The code used is to export messages by date and the messages still on outlook. Sometimes the same dates are chosen by mistake, because of that the errors occur.The code used export messages by date and the messages still on outlook. But if is not possible to change the code I undestand. Thank you.

    • Vagston,

      I can create a workaround. Which do you prefer, skipping over any message that’s already been exported or exporting it a second time?

    • Hi David,
      I prefer skipping over any message that’s already been exported.(with same entryID). Tks.

    • Good morning, Vagston.

      Please replace the ExportMessagesToExcel subroutine with the version below. Leave the rest of the code as is. This version checks to see if a folder with the message’s EntryID already exists. If it does, then it skips that message. Otherwise, it creates the folder and exports the message and its attachments.

      Private Sub ExportMessagesToExcel(olkFol As Outlook.MAPIFolder)
          '--> Declare some variables
          Dim olkMsg As Object, _
              olkAtt As Object, _
              olkCol As Object, _
              olkLst As Object, _
              objFol As Object, _
              strAtt As String, _
              strPth As String
          'Process the current folder and write its messages to the spreadsheet
          Set olkCol = olkFol.Items
          olkCol.Sort "ReceivedTime"
          Set olkLst = olkCol.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
          'Write messages to spreadsheet
          For Each olkMsg In olkLst
              'Only export messages, not receipts or appointment requests, etc.
              If olkMsg.Class = olMail Then
                  strAtt = ""
                  'Create a new file system folder to store the message and its attachments
                  strPth = ROOT_PATH & "\" & olkMsg.EntryID
                  If objFSO.FolderExists(strPth) Then
                      'Do nothing.  The message has been exported before, so skip it.
                  Else
                      Set objFol = objFSO.CreateFolder(strPth)
                      'Save a plain-text version of the email to the folder
                      olkMsg.SaveAs objFol.Path & "\Message.txt", olTXT
                      'Save the attachments to the folder
                      For Each olkAtt In olkMsg.Attachments
                          If Not IsHiddenAttachment(olkAtt) Then
                              olkAtt.SaveAsFile objFol.Path & "\" & olkAtt.FILENAME
                              strAtt = strAtt & olkAtt.FILENAME & ", "
                          End If
                      Next
                      If Len(strAtt) > 0 Then strAtt = Left(strAtt, Len(strAtt) - 2)
                      'Add a row for each field in the message you want to export
                      excWks.Cells(lngRow, 1) = olkMsg.Parent.FolderPath
                      excWks.Cells(lngRow, 2) = olkMsg.Subject
                      excWks.Cells(lngRow, 3) = olkMsg.To
                      excWks.Cells(lngRow, 4) = olkMsg.SenderName
                      excWks.Cells(lngRow, 5) = olkMsg.CC
                      excWks.Cells(lngRow, 6) = strAtt
                      excWks.Cells(lngRow, 7) = olkMsg.EntryID
                      excWks.Hyperlinks.Add Anchor:=excWks.Range("H" & lngRow, "H" & lngRow), Address:="file://" & objFol.Path, TextToDisplay:="View Original Items"
                      lngRow = lngRow + 1
                      lngCnt = lngCnt + 1
                      Set olkAtt = Nothing
                  End If
              End If
              DoEvents
          Next
          Set olkCol = Nothing
          Set olkLst = Nothing
          Set olkMsg = Nothing
          Set objFol = Nothing
      End Sub
      
  9. Hi David,

    In relation to my previous question, I have a picture example of the current spreadsheet we use. Would it be possible to eamil this to you or send this to you in any way? I feel I could better explain what I’m trying to do that way. I would also like to keep the current format if possible. Thanks again.

    • Hi, Sam.

      I think this will do it. To use this

      1. Open Notepad
      2. Copy the code and paste it into Notepad
      3. Edit the code as required
      4. Save the file. You can name it anything you like so long as the file extension is .vbs
      5. Using Windows Task Scheduler, create a new task
      6. Schedule the task to run at whatever interval you desire
      7. Set the task to run the script saved in step #4

      That should do it. Please try this out and let me know if this is what you wanted.

      'On the next line, edit the path to the target workbook.
      Const WORKBOOK_PATH = "c:\users\david\documents\testarea\sam.xlsx"
      Const TeraExport = "Export Messages to Excel (Rev 18)"
      Const olFolderInbox = 6
      Const olMail = 43
      
      Dim olkApp, olkSes, olkFld, olkMsg, excApp, excWkb, excWks, intRow, objFSO, bolExs
      Set objFSO = CreateObject("Scripting.FileSystemObject")
      Set excApp = CreateObject("Excel.Application")
      'Check to see if the workbook already exists.  If it doesn't, then create it.
      bolExs = objFSO.FileExists(WORKBOOK_PATH)
      If bolExs Then
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
      Else
          Set excWkb = excApp.Workbooks.Add()
      End If
      Set excWks = excWkb.Worksheets(1)
      If bolExs Then
          intRow = excWks.UsedRange.Rows.Count + 1
      Else
          'Write Excel Column Headers
          With excWks
              .Cells(1, 1) = "Date"
              .Cells(1, 2) = "Sender"
              .Cells(1, 3) = "Subject"
              .Cells(1, 4) = "Data"
          End With
          intRow = 2
          'Connect to Outlook
          Set olkApp = CreateObject("Outlook.Application")
          Set olkSes = olkApp.GetNamespace("MAPI")
          olkSes.Logon olkApp.DefaultProfileName
          Set olkFld = olkSes.GetDefaultFolder(olFolderInbox)
          'Write messages to spreadsheet
          For Each olkMsg In olkFld.Items
              'Only export messages, not receipts or appointment requests, etc.
              If olkMsg.Class = olMail Then
                  'Add a row for each field in the message you want to export
                  excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
                  excWks.Cells(intRow, 2) = olkMsg.Sender
                  excWks.Cells(intRow, 3) = olkMsg.Subject
                  excWks.Cells(intRow, 4) = FindString(olkMsg.Body, "(.*?)%(.*?)")
                  intRow = intRow + 1
              End If
          Next
          Set olkMsg = Nothing
          If bolExs Then
              excWkb.Close True
          Else
              excWkb.SaveAs WORKBOOK_PATH
              excWkb.Close
          End If
      End If
      'Disconnect from Outlook
      olkSes.Logoff
      Set olkFld = Nothing
      Set olkSes = Nothing
      Set olkApp = Nothing
      'Clean-up objects
      Set excWks = Nothing
      Set excWkb = Nothing
      Set excApp = Nothing
      Set objFSO = Nothing
      WScript.Quit
       
      Function FindString(strText, strFind)
          Dim objRegEx, colMatches, objMatch
          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
      
  10. I have a last question.
    I would like to save the exported files in an excel with extension “.xlsm”.
    I think I need to change the below code part: excWkb.SaveAs strFil
    Could you please tell me what to put instead?

    Thanks.

    • Sarah,

      You’re welcome.

      To save the file in .xlsm format, change this line

      excWkb.SaveAs strFil
      

      to

      excWkb.SaveAs strFil, 53
      
    • hi,
      it works now perfect but when there is color on the attached file, there is a message that: the attached file can’t be save. what should I add on the macro so that I could save attached file with some color inside.

      Thanks.

    • Hi, Sarah.

      “but when there is color on the attached file”

      Sorry, I don’t understand what that means. Do you mean when the spreadsheet contains one or more cells of various color?

    • hi,
      yes, Some tables in the attached files contain color and the macro can’t save these tables because of the color.

    • Sarah,

      “the macro can’t save these tables because of the color”

      The macro doesn’t save a table. It saves the file the table is in. Are you saying that the macro can’t save the attachment or that it can’t save the spreadsheet the code is copying the table into?

    • Sarah,

      Is there an error message? If there is, what is it (exact wording, please)? What makes you think that colors inside the spreadsheet are causing the problem?

  11. Hi David. Thanks once again for this, it’s been great for research and actually learning VBA scripting. I have a question, though, regarding Rev. 18, with the server capacity. I have use for that particular version for the same reason, but I was wondering if it would be possible to get these emails from a sub folder, write the percentage and the name of the server to an excel sheet, and then re-do this every day without deleting the previous percentages. Any advice or help that you could offer would be greatly appreciated, as I’m without a paddle with this one, I’m afraid. Thanks once again.

    • Hi, Sam.

      You’re welcome.

      I’m not sure I understand what you want. The code already works against any folder you select. It also updates a spreadsheet if the spreadsheet already exists. Are you saying that you want the solution to run automatically on a schedule and not require any input from you?

  12. Hi David,

    I am really impressed by this page and how you are taking the time to respond to requests!I thought that version 21 would work in my situation, however I cannot get it to work.

    I have an automated report that gets pulled and sent to me in the body of the email.
    I will use a rule to start the script automatically when the email arrives in a given folder

    I need to:
    1: copy all of the body of the email (no sent from, subject, etc.) to sheet1 in a predetermined excel file
    2: active a macro in that excel file
    3:move the message to another folder in outlook

    Sorry if I am just missing something simple.

    I really appreciate the help!

    -Miles

    • Hi, Miles.

      Thanks!

      I need a little more information.

      1. Do you want the entire body or just a portion of the body? If it’s the latter, then what part of the body and how can I separate that portion from the rest of the body?
      2. Where do you want the body/body fragment inserted into the spreadsheet? Does the solution need to insert a page or insert the text into an existing page? if it’s the latter, then should the solution insert a new row into the spreadsheet
    • Also, I seem to be having a problem. I have used Rev 31 to try and solve my problem, but instead of just writing the number directly after a set word, it just writes every message in my mailbox to an excel sheet. Again, any help you could ofer would be greatly appreciated.

    • David,

      I need the entire body of the message and would like it pasted into an existing sheet, “Sheet1″ (it’s a blank sheet so it would be pasted starting in A1).

      Thanks so much!

    • David,

      I don’t think my last post went through…

      I want the entire body and it needs to be pasted into sheet1 starting at A1

    • Hi, Miles.

      I did receive the previous message. Comments don’t appear until I approve them and sometimes I don’t approve a comment until I’m ready to act on it (i.e. I use the list of comments I haven’t approved as a task list). That’s the case on here.

    • Hi, Miles.

      Sorry to be so slow getting back to you.

      So the first message in A1. Does the next go in A2 or B1? Also, do you want the plain-text version of the message body or the un-rendered HTML version? I’m not aware of any way to insert the rendered HTML into a single cell.

    • David,

      No problem.

      Here’s a sample of what I get in the body of the email message I’m working with:

      Ledger :|**********
      Company :|****
      GL Period :|FEB-15
      From GL Date:|01-FEB-2015
      To GL Date :|28-FEB-2015

      and In excel I want it to be like this:

      A1: Ledger :|**********
      A2: Company :|****
      A3: GL Period :|FEB-15
      A4: From GL Date:|01-FEB-2015
      A5: To GL Date :|28-FEB-2015

      And so on…

      Basically if I do Ctrl-A to select everything in the message body, I can than copy that and then in A1 I paste it and each row in the email body gets it’s own row in excel.

      So really it’s just the same as if you were to copy the text of any email and then paste it into excel like the example below:

      Sample email message.

      Please take note of order, shipments, order, shipments, order, shipments, order, shipments, order, and shipments.

      Thank you.

      ”””This would then be pasted into excel and would look like what’s below”””””

      A1: Sample email message.
      A2:
      A3: Please take note of order, shipments, order, shipments, order, shipments, order, shipments, order, and shipments.
      A4:
      A5:Thank you.

      To answer your last question, I think it would be plan text.

      Thanks so much

    • Miles,

      Ok. If the first message goes in A1:A5, where does the second message go? Will it be B1:B5 or A6:A10?

    • I only need it to do one message to one location. The macro that is triggered after it is pasted to the new sheet will clear out that sheet after the procedure is finished, therefore, the daily report will always get pasted to the same spot.

    • Miles,

      I believe this will do what you’ve described. Please follow the instructions from my original post to add the code to Outlook. Once you’ve added the code, create a rule that fires for the messages you want to process. Set that rule’s action to “run a script” and select this script (ExportMessagesToExcel) as the one to run.

      Option Base 1
      
      '--> Declare some constants
          'On the next line edit the path to the workbook
          Const WORKBOOK_PATH = "C:\Users\David\Documents\TestArea\Miles.xlsm"
          'On the next line edit the path to the Outlook folder the message will be mvoed to after processing it
          Const FOLDER_PATH = "Personal Folders\History"
          'On the next line edit the name of the Excel macro to run after the data is added to Excel.  Be sure to include the name of the module the macro is in.
          Const EXCEL_MACRO = "Sheet1.Macro_Email"
          Const MACRO_NAME = "Export Messages to Excel (Rev Miles)"
       
      Sub ExportMessagesToExcel(Item As Outlook.MailItem)
          'Declare some variables
          Dim excApp As Object, excWkb As Object, excWks As Object, lngRow As Long, arrLin As Variant
           
          'Get the folder object of the folder the message is to be moved to
          Set olkFld = OpenOutlookFolder(FOLDER_PATH)
       
          'Connect to Excel
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Worksheets(1)
           
          'Get data from the message and put it into the spreadsheet
          arrLin = Split(Item.Body, vbCrLf)
          For lngRow = 1 To 5
              excWks.Cells(lngRow, 1) = arrLin(lngRow)
          Next
           
          'Move the message to a folder
          Item.Move olkFld
           
          'Run an Excel macro
          excApp.Run EXCEL_MACRO
           
          'Save and close the workbook
          excWkb.Close True
       
          'Clean-up open objects to avoid memory leaks
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
       
      Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
          ' Purpose: Opens an Outlook folder from a folder path.
          ' Written: 4/24/2009
          ' Author:  David Lee
          ' Outlook: All versions
          Dim arrFolders As Variant, _
              varFolder As Variant, _
              bolBeyondRoot As Boolean
          On Error Resume Next
          If strFolderPath = "" Then
              Set OpenOutlookFolder = Nothing
          Else
              Do While Left(strFolderPath, 1) = "\"
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
              Loop
              arrFolders = Split(strFolderPath, "\")
              For Each varFolder In arrFolders
                  Select Case bolBeyondRoot
                      Case False
                          Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                          bolBeyondRoot = True
                      Case True
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                  End Select
                  If Err.Number <> 0 Then
                      Set OpenOutlookFolder = Nothing
                      Exit For
                  End If
              Next
          End If
          On Error GoTo 0
      End Function
      
  13. Hi, I’ve found this very useful, thanks for the code.
    I’m looking to have a column identify the store name and/or PST path. I’ve tried a few things but not got it to work, any sugestions?

    • Hi, Robin.

      Thanks! I’m glad it’s useful.

      You can get the store name and path (assuming that the store is a datafile and not an Exchange store) with something like this

      Set olkSto = Session.GetStoreFromID(olkMsg.Parent.StoreID)
      strStoreName = olkSto.DisplayName
      strStorePath = IIf(olkSto.IsDataFileStore, olkSto.FILEPATH, "")
      
    • Thanks again for the quick response. Got it working as I needed. Now to set it going on many terabytes of email archives.

    • Working my way through the multiple archives I need to list. Code working great, however, I’ve come across an odd problem caused by a few bad emails.

      Where the code comes across a message with the following subject line (or similar) the macro halts with:

      Run-time error ‘1004’
      Application-defined or object-defined error

      Subject: =?UTF-8?B?My41JSBJU0EsIMKjMjggVGVzY28gcHJvZml0LCAyMCUgb2ZmIGNvZGVzLCDCozIwMCBuZXRib29rcywgYmFuayBjaGFyZ2VzIG5ldyBsZWdhbHMsIFBpenphIEh1dCAyZm9yMSwgZnJlZSBHcmF6aWEvSGVhdCB3aXRoIGRpZXQgY29rZSwgZnJlZSAxMTggZnJvbSBtb2JpbGVzLCDCozEgY29kZSBmb3IgQW1hem9uIE1QM3M=?=

      Thankfully these messages are rare and this has only occurred with one users email. Would you be able to suggest the best way handle this error without stopping the macro from operating?
      Preferably the code would insert a placeholder (eg [invalid subject]) in the Excel spreadsheet in the subject column that could later be searched for and investigated.

    • > Does the bad subject always begin with “=?UTF”?
      Yes, all the problem messages I’ve found have started that way.

    • Robin,

      Ok. Please replace this line of code

      excWks.Cells(intRow, 1) = olkMsg.Subject
      

      with

      excWks.Cells(intRow, 1) = IIF(Left(olkMsg.Subject,5) = "=?UTF", "Invalid Subject", olkMsg.Subject)
      

      This will check the first five characters of each message’s subject to see if it begins with “=?UTF”. If it does, then the code will insert “Invalid Subject” into the spreadsheet. Otherwise, the code will insert the message subject into the spreadsheet.

    • Thanks for the quick response, I was busing thinking over more complex error handling but the simple approach works. Just what I needed.

      300,000 down, a few million messages to go…

  14. Hi David,

    I have a question. Do we have option to compare received emails in inbox and sent emails with subject, date, time, sender, receiver, their email address. This will help to keep a track of emails that we have answered.

    • Hi, litesh.

      Yes, a script could make that comparison. That said, comparing sent messages to received messages isn’t the best or most efficient means of determining which messages you’ve responded to. The problem with comparing messages is that it doesn’t work well for all scenarios. A better solution is to assign a tracking number to each message as it arrives and then incorporate that tracking number in the response. You could then compare the tracking numbers of messages in the inbox to those in sent items to determine which ones you’ve responded to. Or, better, mark a message as “replied to” once you’ve replied. That would actually be simpler since it wouldn’t require any scripting at all. You could simply create a “Replied To” category and add it to messages as you reply to them.

    • Hi, Sarah.

      The answer depends on what what “export” means in this context. Are you talking about actually embedding the file (i.e. using OLE to embed the file) in the spreadsheet, saving the attachment to disk and inserting a link to it in the spreadsheet, copy the file contents and inserting that in the spreadsheet, exporting the attachment name(s) to a spreadsheet, or something else?

    • Hi,
      I Will explain what i need.Each day, i receive mails with attached excel file.I would like to copy paste the content of excel file for each selected mail in a unique excel file.Each attached file contents table or some information and i need to see all this on one sheet to work on.

      Thanks

    • Hi,
      I receive mails every day with attached excel file on it. There is a table or some information in each excel file.
      I would like to copy past the content of each excel file (from selected mails)in a unique excel file, so I could work on it. Is it possible?

      Thanks

    • Hi, Sarah.

      Yes, that should be doable so long as the Excel files you receive are consistently formatted, you can define the data you want (e.g. extract the same table or same set of cells), and can articulate a rule for where to place the copied data in the target spreadsheet (i.e. the spreadsheet the data is to be copied to). I would need to know those details in order to create a solution.

    • Hi,
      The excel file attached on each mail Will content only a table but the format Will be different from an excel file to another.For each table,there is maximum 10columns but the number of lines is unknown.

    • Hi, Sarah.

      Will the table always be on the same sheet (e.g. sheet 1)? Will the table always start in the same location (i.e. same row and column)?

    • hi David,
      the table will always be on the same sheet (sheet1) .Most of the times , the table starts in the first column but in rows 1, 2 or 3. Sometimes, it start in the second column and in rows 1, 2 or 3 but no more.Is it possible to do that?

    • Sarah,

      So long as the worksheet doesn’t contain anything but the one table, then I should be able to make this work by having the code locate the first non-blank cell. That cell should be the beginning of the table. I can then have the code work across and down to find the rest of the table so lone as there aren’t any blank columns/rows in the table.

    • Hi, Sarah.

      I think this will do what you want. Please try it out and let me know if I got it right. Please follow the instructions from the original post to add this code to Outlook.

      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              olkAtt As Outlook.Attachment, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              excBk1 As Object, _
              excWk1 As Object, _
              lngRow As Long, _
              lngCol As Long, _
              lngR1 As Long, _
              lngR2 As Long, _
              lngC1 As Long, _
              lngC2 As Long, _
              intCnt As Integer, _
              intVer As Integer, _
              strFil As String, _
              strTmp As String, _
              bolH1 As Boolean, _
              bolH2 As Boolean
          strFil = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
          If strFil <> "" Then
              strTmp = Environ("TEMP") & "\"
              intVer = GetOutlookVersion()
              Set excApp = CreateObject("Excel.Application")
              Set excWkb = excApp.Workbooks.Add()
              Set excWks = excWkb.ActiveSheet
              'Write Excel Column Headers
              With excWks
                  .Cells(1, 1) = "Subject"
                  .Cells(1, 2) = "Received"
                  .Cells(1, 3) = "Sender"
              End With
              lngRow = 2
              'Write messages to spreadsheet
              For Each olkMsg In Application.ActiveExplorer.Selection
                  'Only export messages, not receipts or appointment requests, etc.
                  If olkMsg.Class = olMail Then
                      bolH1 = False
                      For Each olkAtt In olkMsg.Attachments
                          Select Case LCase(Right(olkAtt.FILENAME, 5))
                              Case ".xlsx"
                                  olkAtt.SaveAsFile strTmp & olkAtt.FILENAME
                                  bolH1 = True
                                  Exit For
                          End Select
                      Next
                      If bolH1 Then
                          Set excBk1 = excApp.Workbooks.Open(strTmp & olkAtt.FILENAME)
                          Set excWk1 = excBk1.Worksheets(1)
                          bolH2 = False
                          For lngR1 = 1 To 3
                              For lngC1 = 1 To 2
                                  If excWk1.Cells(lngR1, lngC1).value <> "" Then
                                      bolH2 = True
                                      Exit For
                                  End If
                              Next
                              If bolH2 Then
                                  Exit For
                              End If
                          Next
                          If bolH2 Then
                              'Add a row for each field in the message you want to export
                              excWks.Cells(lngRow, 1) = olkMsg.Subject
                              excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                              excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
                              lngR2 = lngR1
                              Do Until excWk1.Cells(lngR2, lngC1).value = ""
                                  lngCol = 4
                                  For lngC2 = lngC1 To lngC1 + 10
                                      excWks.Cells(lngRow, lngCol) = excWk1.Cells(lngR2, lngC2).value
                                      lngCol = lngCol + 1
                                  Next
                                  lngR2 = lngR2 + 1
                                  lngRow = lngRow + 1
                              Loop
                              Set excWk1 = Nothing
                              excBk1.Close False
                              Set excBk1 = Nothing
                              lngRow = lngRow + 1
                              intCnt = intCnt + 1
                          End If
                      End If
                  End If
              Next
              Set olkMsg = Nothing
              excWkb.SaveAs strFil
              excWkb.Close False
          End If
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          MsgBox "Process complete.  A total of " & intCnt & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
      End Sub
       
      Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
          Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
          On Error Resume Next
          Select Case intOutlookVersion
              Case Is < 14
                  If Item.SenderEmailType = "EX" Then
                      GetSMTPAddress = SMTP2007(Item)
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
              Case Else
                  Set olkSnd = Item.Sender
                  If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                      Set olkEnt = olkSnd.GetExchangeUser
                      GetSMTPAddress = olkEnt.PrimarySmtpAddress
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
          End Select
          On Error GoTo 0
          Set olkPrp = Nothing
          Set olkSnd = Nothing
          Set olkEnt = Nothing
      End Function
       
      Function GetOutlookVersion() As Integer
          Dim arrVer As Variant
          arrVer = Split(Outlook.Version, ".")
          GetOutlookVersion = arrVer(0)
      End Function
       
      Function SMTP2007(olkMsg As Outlook.MailItem) 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,
      First, I would like to thank you for all this help.
      It works but exports only excel files with extension “.xlsx”, but not the files with extension “.xls”.
      is there something to change in the macro in order to export also the files with extension “.xls” ?

    • You’re welcome, Sarah.

      Yes. Change these two lines

      Select Case LCase(Right(olkAtt.FILENAME, 5))
          Case ".xlsx"
      

      to

      Select Case LCase(Right(olkAtt.FILENAME, 4))
          Case "xlsx",".xls"
      
  15. Hey David. this is great stuff thanks for posting it. I am looking for something like Rev1 and Rev4. coding the folders to be exported, code a date range of (Date-7 to Date), enter an export path (each folder should append to the first available row). Also, a timer that will run the code every Wednesday at 3pm. Thanks

    • Hi, Zack.

      You’re welcome. I’m glad you like it.

      Here’s the code for doing this. Since Outlook does not have a built-in means of scheduling a macro, I’ve written the code in VBscript so you can run it using Windows’ Task Scheduler. Here’s what you’ll neeed to do.

      1. Open Notepad.
      2. Copy the code and paste it into Notepad.
      3. Edit the code per the comments I included in it.
      4. Save the file. You may name it anything you like. The file must have a .vbs extension.
      5. Using Windows Task Scheduler, create a new task that runs each Wednesday at 3pm.
      6. Set that task to run a script and select the script you saved in step #4 as the script to run.

      That should do it. Note that this script does not create the Excel workbooks nor verify that they exist beforehand. It assumes that they exist and that the path is correct.

      Const MACRO_NAME = "Export Messages to Excel (Rev Zack)"
      
      Dim olkApp, olkSes
       
      '--> Connect to Outlook
      Set olkApp = CreateObject("Outlook.Application")
      Set olkSes = olkApp.GetNamespace("MAPI")
      olkSes.Logon olkApp.DefaultProfileName
      
      '--> Main routine
      'Add as many exports as you need. Each export is controlled by a line like the following
      'The format of the command is ExportMessagesToExcel "Path to Workbook", "Path to Outlook Folder"
      ExportMessagesToExcel "C:\Folder1.xlsx", "Personal Folders\Folder1"
      ExportMessagesToExcel "C:\Folder2.xlsx", "Personal Folders\Folder2"
      
      '--> Disconnect from Outlook
      olkSes.Logoff
      Set olkSes = Nothing
      Set olkApp = Nothing
      
      '--> Terminate the script
      WScript.Quit
       
      Sub ExportMessagesToExcel(strFilename, strFolderPath)
          Const olMail = 43
          Dim olkMsg, olkFld, olkLst, excApp, excWkb, excWks, lngRow, intVer, datBeg, datEnd
          If strFilename <> "" Then
              If strFolderPath <> "" Then
                  Set olkFld = OpenOutlookFolder(strFolderPath)
                  If TypeName(olkFld) <> "Nothing" Then
                  	datBeg = DateAdd("d", -7, Date) & " 12:00"
                  	datEnd = Date & " 23:59"
                      intVer = GetOutlookVersion()
                      Set excApp = CreateObject("Excel.Application")
                      Set excWkb = excApp.Workbooks.Open(strFilename)
                      Set excWks = excWkb.Worksheets(1)
                      lngRow = excWks.UsedRange.Rows.Count + 1
                      Set olkLst = olkFld.Items.Restrict("[ReceivedTime] >= '" & OutlookDateFormat(datBeg) & "'" & " AND [ReceivedTime] <= '" & OutlookDateFormat(datEnd) & "'")
                      'Write messages to spreadsheet
                      For Each olkMsg In olkLst
                          'Only export messages, not receipts or appointment requests, etc.
                          If olkMsg.Class = olMail Then
                              'Add a row for each field in the message you want to export
                              excWks.Cells(lngRow, 1) = olkMsg.Subject
                              excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                              excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
                              lngRow = lngRow + 1
                          End If
                      Next
                      Set olkMsg = Nothing
                      excWks.columns("A:C").AutoFit
                      excWkb.Close True
                  Else
                      MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
                  End If
              Else
                  MsgBox "The folderpath was empty.", vbCritical + vbOKOnly, MACRO_NAME
              End If
          Else
              MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
          End If
          Set olkMsg = Nothing
          Set olkFld = Nothing
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
       
      Function OpenOutlookFolder(strFolderPath)
          Dim arrFolders, varFolder, bolBeyondRoot
          On Error Resume Next
          If strFolderPath = "" Then
              Set OpenOutlookFolder = Nothing
          Else
              Do While Left(strFolderPath, 1) = "\"
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
              Loop
              arrFolders = Split(strFolderPath, "\")
              For Each varFolder In arrFolders
                  Select Case bolBeyondRoot
                      Case False
                          Set OpenOutlookFolder = olkSes.Folders(varFolder)
                          bolBeyondRoot = True
                      Case True
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                  End Select
                  If Err.Number <> 0 Then
                      Set OpenOutlookFolder = Nothing
                      Exit For
                  End If
              Next
          End If
          On Error GoTo 0
      End Function
       
      Private Function GetSMTPAddress(Item, intOutlookVersion)
      	Const olExchangeUserAddressEntry = 0
          Dim olkSnd, olkEnt
          On Error Resume Next
          Select Case intOutlookVersion
              Case 1-13
                  If Item.SenderEmailType = "EX" Then
                      GetSMTPAddress = SMTP2007(Item)
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
              Case Else
                  Set olkSnd = Item.Sender
                  If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                      Set olkEnt = olkSnd.GetExchangeUser
                      GetSMTPAddress = olkEnt.PrimarySmtpAddress
                  Else
                      GetSMTPAddress = Item.SenderEmailAddress
                  End If
          End Select
          On Error GoTo 0
          Set olkPrp = Nothing
          Set olkSnd = Nothing
          Set olkEnt = Nothing
      End Function
       
      Function GetOutlookVersion()
          Dim arrVer
          arrVer = Split(olkApp.VERSION, ".")
          GetOutlookVersion = arrVer(0)
      End Function
       
      Function SMTP2007(olkMsg)
          Dim olkPA
          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
      
      Function OutlookDateFormat(varDate)
          Dim intHour, strAMPM
          intHour = Hour(varDate)
          If intHour > 12 Then
              intHour = intHour - 12
              strAMPM = "PM"
          Else
              strAMPM = "AM"
          End If
          OutlookDateFormat = Month(varDate) & "/" & Day(varDate) & "/" & Year(varDate) & " " & intHour & ":" & Minute(varDate) & " " & strAMPM
      End Function
      
  16. This is a great resource – thanks so much for providing this code!

    I’d like to know if it’s possible to create code that would export only selected emails within a folder? For example, I’d like to select emails in my inbox folder by highlighting the message and export only those.

    • Hi, Mike.

      Thanks and you’re welcome.

      Yes, that’s doable. Assuming that you’re using the code from the original post, then all you need to do is change this line

      For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
      

      to

      For Each olkMsg In Application.ActiveExplorer.Selection
      
  17. Hi David, thanks very much for this code, it has really helped me. I do however, have one question. Is it possible to add the outlook mail to an existing excel sheet without erasing whatever text you already have on your excel sheet? Thank you very much in advance.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s