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,275 comments on “Exporting Outlook Messages to Excel

  1. Hi David,

    Are you able to create a version similar to Rev 14, but only there are multiple key words in the same line?

    For example, the body of the message is of the form-

    —————————————
    NOTICE Header Code: XXX
    Ticket No: YYYYYYYYYY Seq.No: Z
    Update of:

    Original Call Date: 09/29/2014 Time: 02:14:46AM

    Caller Address: UNIT 2
    US, CA #####
    —————————————

    The keywords are: Header Code, Ticket No, Seq.No, Update of, Original Call Date, Time, Caller Address, etc, etc (I would like to add many more keywords)

    I need the keywords to be on the first row on separate columns as headings and parse all the emails and put the content under appropriate columns.

    IMPORTANT: I also need a column for the “categories” field… The color-coding of emails in Outlook is crucial information for me and I would also like to display that under one of the columns.

    Also, because I am really bad at scripting, could you please write a comment where I can add the extra keywords and what kinds of editions I need to do to have it run properly with custom keywords?

    Thank you

    • Hi, Andrew.

      I think I can manage that. I do have a question about how you want to handle “Categories”. Do you just want the category name from Outlook or do you want the color, or perhaps both?

    • Oh thanks so much for the super quick reply.

      The names of the colors for the categories is good.
      For example, I can have the emails categorized in multiple colors (ie. red and green) in this case, I think something like “red,green” is sufficient.

      Thank you!

    • Hi, Andrew.

      Please try this version and let me know if it works for you.

      Const MACRO_NAME = "Export Messages to Excel (Rev Andrew)"
       
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long, _
              intVer As Integer, _
              strFil As String
      
          'strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
          strFil = "c:\users\david\documents\testarea\jmapark91.xlsx"
          If strFil <> "" Then
              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) = "Categories"
                  .Cells(1, 5) = "Header Code"
                  .Cells(1, 6) = "Ticket No"
                  .Cells(1, 7) = "Seq No"
                  .Cells(1, 8) = "Update Of"
                  .Cells(1, 9) = "Date"
                  .Cells(1, 10) = "Time"
                  .Cells(1, 11) = "Caller 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.Subject
                      excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
                      excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
                      excWks.Cells(lngRow, 4) = olkMsg.Categories
                      excWks.Cells(lngRow, 5) = Replace(FindString(olkMsg.Body, "\bHeader Code: (.+)\b"), "Header Code: ", "")
                      excWks.Cells(lngRow, 6) = Replace(FindString(olkMsg.Body, "\bTicket No:\s[a-zA-Z0-9]*\s"), "Ticket No: ", "")
                      excWks.Cells(lngRow, 7) = Replace(FindString(olkMsg.Body, "Seq.No: (.+)\b"), "Seq.No: ", "")
                      excWks.Cells(lngRow, 8) = Replace(FindString(olkMsg.Body, "\bUpdate of: (.+)\b"), "Update of: ", "")
                      excWks.Cells(lngRow, 9) = Replace(FindString(olkMsg.Body, "\bCall Date:\s[0-9]{2}/[0-9]{2}/[0-9]{4}"), "Call Date: ", "")
                      excWks.Cells(lngRow, 10) = Replace(FindString(olkMsg.Body, "\sTime: (.+)\b"), " Time: ", "")
                      excWks.Cells(lngRow, 11) = Replace(FindString(olkMsg.Body, "\bCaller Address: (.+)\b"), "Caller Address: ", "")
                      lngRow = lngRow + 1
                      lngCnt = lngCnt + 1
                  End If
              Next
              Set olkMsg = Nothing
              excWks.Columns("A:K").AutoFit
              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, "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 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
      
    • Sorry also, how would I access information like “modified time” and “priority”?
      If I do a linked table between Outlook and Access I can see these fields so I know these exist, but how do I access these fields using vba? I tried olkMsg.Categories and it exists but not olkMsg.Priority and olkMsg.Modified.

      Again, thanks a lot.

    • Andrew,

      What you know as “Priority” is the property named “Importance”. “Modified” is the “LastModificationTime” property. In Outlook’s VB editor you can view a complete list of objects and their associated properties by pressing F2, which opens the object browser.

  2. Dear Tom

    how are you , I hope you remember me , currently your provided script is not extracting anything from the emails i am getting on daily basis from table only first three columns are grabbed . other desired columns are empty can you provide your insights on this :)

    Subject Received Sender

    • Hi, Sajjad Haider.

      Yes, I remember you. I’ll take a look at what you sent as soon as I can. I’ll respond once I’ve done that.

  3. Hi David,

    Need your help with report I need to create. I have 5 separate excel workbooks maintained by different individuals. Content will be found on the worksheets named “CCTP”. Each of the workbooks have identical headers. Workbooks have 48 columns of content. Some of the rows are hidden.

    Need to create a VBScript that does the following:
    Once a day (possibly automatically) would like to export the contents of all 5 workbooks into one master workbook (into worksheet named “CCTP Open Cases”) If content in column 1, 2, 3 and 48 match the existing columns in master file, all info should overwrite identical content. All content that does not match these columns should also be copied.

    Content on master should be sorted by column 48. When values of “Yes” are found, the rows with “Yes” need to be copied (and not removed) to an adjacent worksheet “CCTP Closed Cases”.

    Many thanks on advance for your help.

    • Hi, Diana.

      That doesn’t sound too difficult. I’ll put something together and post it as soon as I can.

    • Diana,

      One question. In your requirements you describe what happens if the values in columns 1, 2, 3, and 48 match an existing entry in the master file. What about those entries that don’t match? Do you want them appended to the master file or should the script just ignore them?

    • Diana,

      The code below does everything except for

      When values of “Yes” are found, the rows with “Yes” need to be copied (and not removed) to an adjacent worksheet “CCTP Closed Cases”.

      Before I add that in I need to know how you want to handle existing items (i.e. items that have already been copied to the “CCTP Closed Cases” sheet. Should the script copy them again, update them, or ignore them altogether? Also, should the script use the same logic to match cases (i.e. check to see if the values in columns 1, 2, 3, and 48 match)?

      '--> Declare some constants
      	Const xlAscending = 1
      	Const xlYes = 1
      
      '--> Create some variables
      	Dim excApp, excMWkb, excMWks, excRng
      
      '--> Open an instance of Excel and open the mater workbook
      	Set excApp = CreateObject("Excel.Application")
      	'On the next line, edit the path to the master file
      	Set excMWkb = excApp.Workbooks.Open("c:\users\david\documents\testarea\DP1.xlsx")
      	Set excMWks = excMWkb.Worksheets("CCTP Open Cases")
      
      '--> Process the individual workbooks
      	'Edit the paths to the individual input files as needed
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp1.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp2.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp3.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp4.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp5.xlsx"
      
      '--> Sort the worksheet on column 48
      	excMWks.Range("A1:AV" & excMWks.usedrange.rows.count).Sort "Col-48", xlAscending,,,,,, xlYes
      
      '--> Save and close the master workbook
      	excMWkb.Close True
      
      '--> Delete all open objects
      	Set excMWks = Nothing
      	Set excMWkb = Nothing
      	Set excApp = Nothing
      
      '--> Terminate the script
      	WScript.Quit
      
      Sub ProcessWorkbook(strPth)
      	Dim excWkb, excWks, lngRow, lngCol, lngMst
      	Set excWkb = excApp.Workbooks.Open(strPth)
      	Set excWks = excWkb.Worksheets("CCTP")
      	For lngRow = 2 To excWks.usedrange.rows.count
      		lngMst = ItemInMaster(excWks.cells(lngRow,1).value, excWks.cells(lngRow,2).value, excWks.cells(lngRow,3).value, excWks.cells(lngRow,48).value)
      		If lngMst = 0 Then
      			lngMst = excMWks.usedrange.rows.count + 1
      		End If
      		For lngCol = 1 To 48
      			excMWks.cells(lngMst, lngCol) = excWks.cells(lngRow, lngCol)
      		Next
      	Next
      	excWkb.close False
      	Set excWks = Nothing
      	Set excWks = Nothing
      End Sub
      
      Function ItemInMaster(varCol1, varCol2, varCol3, varCol48)
      	Dim lngRow, bolHit
      	bolHit = False
      	For lngRow = 2 To excMWks.usedrange.rows.count
      		If excMWks.cells(lngRow,1).value = varCol1 Then
      			If excMWks.cells(lngRow,2).value = varCol2 Then
      				If excMWks.cells(lngRow,3).value = varCol3 Then
      					If excMWks.cells(lngRow,48).value = varCol48 Then
      						bolHit = True
      						Exit For
      					End If
      				End If
      			End If
      		End If
      	Next
      	If bolHit Then
      		ItemInMaster = lngRow
      	Else
      		ItemInMaster = 0
      	End If
      End Function
      
    • Diana,

      Here the final version. Please test this thoroughly before using it in a production environment. I think I got it right and it worked properly with the test data I created, but I may have misunderstood a requirement, your data may be different that want I used, or the code might have a bug.

      To use this

      1. Open Notepad
      2. Copy the code and paste it into Notepad
      3. Edit the code per the comments I included in the script
      4. Save the file. Name it anything you like so long as the file extension is .vbs
      5. Double-click the file to run the script

      To run the script on a schedule

      1. Create a task using Windows Task Scheduler
      2. Set the schedule
      3. Set the task to run this script
      '--> Declare some constants
      	Const xlAscending = 1
      	Const xlYes = 1
      
      '--> Create some variables
      	Dim excApp, excMWkb, excMWks, excRng
      
      '--> Open an instance of Excel and open the mater workbook
      	Set excApp = CreateObject("Excel.Application")
      	'On the next line, edit the path to the master file
      	Set excMWkb = excApp.Workbooks.Open("c:\users\david\documents\testarea\DP1.xlsx")
      	Set excMWks = excMWkb.Worksheets("CCTP Open Cases")
      
      '--> Process the individual workbooks
      	'Edit the paths to the individual input files as needed
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp1.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp2.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp3.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp4.xlsx"
      	ProcessWorkbook "c:\users\david\documents\testarea\DPInp5.xlsx"
      
      '--> Sort the worksheet on column 48
      	excMWks.Range("A1:AV" & excMWks.usedrange.rows.count).Sort "Col-48", xlAscending,,,,,, xlYes
      	
      '--> Archive the completed items from master worksheet to the Closed Cases worksheet
      	ArchiveClosedCases
      
      '--> Save and close the master workbook
      	excMWkb.Close True
      
      '--> Delete all open objects
      	Set excMWks = Nothing
      	Set excMWkb = Nothing
      	Set excApp = Nothing
      
      '--> Terminate the script
      	WScript.Quit
      
      Sub ProcessWorkbook(strPth)
      	Dim excWkb, excWks, lngRow, lngCol, lngMst
      	Set excWkb = excApp.Workbooks.Open(strPth)
      	Set excWks = excWkb.Worksheets("CCTP")
      	For lngRow = 2 To excWks.usedrange.rows.count
      		lngMst = ItemInMaster(excWks.cells(lngRow,1).value, excWks.cells(lngRow,2).value, excWks.cells(lngRow,3).value, excWks.cells(lngRow,48).value)
      		If lngMst = 0 Then
      			lngMst = excMWks.usedrange.rows.count + 1
      		End If
      		For lngCol = 1 To 48
      			excMWks.cells(lngMst, lngCol) = excWks.cells(lngRow, lngCol)
      		Next
      	Next
      	excWkb.close False
      	Set excWks = Nothing
      	Set excWks = Nothing
      End Sub
      
      Function ItemInMaster(varCol1, varCol2, varCol3, varCol48)
      	Dim lngRow, bolHit
      	bolHit = False
      	For lngRow = 2 To excMWks.usedrange.rows.count
      		If excMWks.cells(lngRow,1).value = varCol1 Then
      			If excMWks.cells(lngRow,2).value = varCol2 Then
      				If excMWks.cells(lngRow,3).value = varCol3 Then
      					If excMWks.cells(lngRow,48).value = varCol48 Then
      						bolHit = True
      						Exit For
      					End If
      				End If
      			End If
      		End If
      	Next
      	If bolHit Then
      		ItemInMaster = lngRow
      	Else
      		ItemInMaster = 0
      	End If
      End Function
      
      Sub ArchiveClosedCases()
      	Dim excClo, lngR1, lngR2, lngCol, bolHit 
      	Set excClo = excMWkb.worksheets("CCTP Closed Cases")
      	For lngR1 = 2 To excMWks.usedrange.rows.count
      		bolHit = False
      		If excMWks.cells(lngR1,48).value = "Yes" then
      			For lngR2 = 2 To excClo.usedrange.rows.count
      				If excClo.cells(lngR2,1).value = excMWks.cells(lngR1,1).value Then
      					If excClo.cells(lngR2,2).value = excMWks.cells(lngR1,2).value Then
      						If excClo.cells(lngR2,3).value = excMWks.cells(lngR1,3).value Then
      							For lngCol = 1 To 48
      								excClo.cells(lngR2, lngCol).value = excMWks.cells(lngR1, lngCol).value
      								bolHit = True
      							Next
      						End If
      					End If
      				End If
      			Next
      			If Not bolHit Then
      				lngR2 = excClo.usedrange.rows.count + 1
      				For lngCol = 1 To 48
      					excClo.cells(lngR2, lngCol).value = excMWks.cells(lngR1, lngCol).value
      				Next
      			End If
      		End If
      	Next
      	Set excClo = Nothing
      End Sub
      
  4. David,
    First, I want to thank you for your Herculean effort. The help that you are giving us is amazing and you deserve huge kudos for this. Thanks so much!

    Second, I have a specific request which can probably easily be accomplished by a mash up of some of your solutions above – I just don’t know how to combine them then do the right adjustments.

    Situation:
    I’m running Office Professional Plus 2013 and receive mail through an exchange server. I’ve linked up my cell phone to be able to receive text messages in Outlook (you may know, Android on Samsung has an ability to do this).
    I have multiple mailboxes running, but the text message come into one called “peter.winn@talentacademy.cn” the one that is connected to the exchange server. The text messages come in to the Inbox of this mailbox with:
    – a Mobile Phone icon in the Icon column,
    – the mobile number of the sender in the “From” column starting with a “+”, e.g. “+8613817877431″,
    – the text message is in the “Subject” column
    – “” [MOBILE:] (including the two quotation marks) appears in the “To” column
    In Excel I have a sheet that has a list of mobile numbers. These numbers do not have the country code (so in the above example it would be just “13817877431” without the “+86″ at front.

    What I’m Looking to Do:
    – Auto run a macro on receipt of text messages to the Inbox in this mailbox
    – Look in the spread sheet for the matching number (.e.g. in column D) and add into the cell next to this number the most recent text message a) receipt date/time and b) the content of this message concatenated together with a tab space in between (e.g. 10/25/2014 1:26PM Thanks for the meeting. I agree.) I I’d like to just keep adding to the contents of the cell, with the latest message on top. Small detail but the cell content should be aligned top and left. I’m not sure of the max capacity of a single cell, but since I have other information on a single line in columns A, B and C, I wanted to try to get the Text message info in column E.
    – This is on an existing spreadsheet called “D:\Belmont\A-Talent Academy\Marketing Dept\TestGetMail.xlsm” and the sheet is called “TestSMS”. The macro should check if the spreadsheet is open and if so just add it to this. If the spread sheet is not open, it should still add it to the spreadsheet (e.g. open in the background and then close – I think I saw somewhere this is possible).
    – Ideally it could also put a hyperlink in the excel file. If we can do this, it’s best to put this hyperlink in the cell next to the mobile number (column e), hyperlink using an “X”, and then the concatenated time/date and message info in the cell next to that (column f). The column containing the time/date and message cell is very wide so best for this to be last. I can change the format and headings of the spreadsheet to match.

    Problems I’ve run into:
    1. Tried running a rule in Outlook for auto sorting these text messages into a separate folder by using the “+86″ as a key, but Outlook won’t auto run for this type of message. There seem to be many forum discussions on this but no solution.
    2. Tried exporting the message content using some other expert’s code, but it cut off the message content when it put it into a cell in excel (for some messages but not all – strange)

    Thanks so much for any help – I really appreciate this!

    Peter

    • Hi, Peter.

      What you described doesn’t sound too difficult. I do have one question about the hyperlink. What is it that you want it to link to? The message in Outlook?

    • David, Yes, let’s just hyperlink to open the most recent message in Outlook from that particular number. The cell that stores the message log in Excel would have the whole history with the most recent first (I’m not sure what the max capacity of a cell is, but each of the SMS messages received will not be that long and the total will likely not be more than 10 from one single number). I’d like to squeeze in a column in excel that has an integer representing the number of messages received, but I think I can handle that in excel myself as long as you can help me with the Outlook side.
      Thanks again so much! You are super!
      Peter

    • David, actually on this topic, I wanted to ask a couple general questions. Right now I was able to link Outlook to send text messages through my phone through an account setting on the Samsung Note 2 phone (as I described). But I found other people who don’t have the same phone hardware seem not to have this setting on their phones – to link their number to Outlook on an exchange server so they can send emails thru Outlook. Is this unique to just certain builds of Android (e.g. the Samsung version)? If yes, is there some app that people without this Android version can download to do the same thing? Separately,is there a way to set up an IP outbound phone line on the server and just use this rather than link to individual phones – I guess you’d have to add a reply code so inbound messages could be routed by the server to the right individual Outlook account. Ultimately I’m looking for a way to avoid the group using their individual phones. Thanks!

    • Peter,

      “Is this unique to just certain builds of Android (e.g. the Samsung version)?”
      “Separately,is there a way to set up an IP outbound phone line on the server …”

      I don’t use Android and therefore cannot answer either question.

    • David,
      Sorry, there was a note that said “awaiting moderation” above this note for several days, so I’ll try again to send it here.
      Yes, let’s just hyperlink to open the most recent message in Outlook from that particular number. The cell that stores the message log in Excel would have the whole history with the most recent first (I’m not sure what the max capacity of a cell is, but each of the SMS messages received will not be that long and the total will likely not be more than 10 from one single number). I’d like to squeeze in a column in excel that has an integer representing the number of messages received, but I think I can handle that in excel myself as long as you can help me with the Outlook side.
      Thanks again so much! You are super!
      Peter

    • Peter,

      The note was there because I hadn’t approved the comment yet. I often hold off on approving a comment until I’m ready to work on it. I’d seen it, just haven’t gotten to it yet.

    • Peter,

      Keeping in mind that I don’t use use any Android devices and don’t have an SMS account set up in Outlook, here’s my first cut at a solution. There will likely be some problems with this because I’ve no means of testing in the type of environment that you’re in. This version of the code has to be run manually. Once we get the kinks worked out I’ll add code for running the solution automatically each time a text-message arrives.

      To add the code

      1. Open Outlook
      2. Press ALT+F11 to open the VB editor
      3. Looking in the Project pane on the left-hand side of the screen, if not expanded, expand Project1
      4. If not expanded, expand Microsoft Outlook Objects
      5. Double-click on the ThisOutlookSession module
      6. Copy the code and paste it into the left-hand pane of the VB editor
      7. Edit the code per the comments I included in it (i.e. the green lines)
      8. Close the VB editor

      Once the code is in place we need to test it. To do that

      1. Make a backup copy of your Excel workbook in case things go badly
      2. Select one of the text messages
      3. Run the macro TestSaveTextMessageToExcel
      4. Let me know what happens
      Sub SaveTextMessageToExcel(olkSMS As Outlook.MobileItem)
          'On the next line, edit the path to and name of the spreadsheet.
          Const WKB_PATH = "c:\users\david\documents\testarea\peter.xlsx"
          Dim excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              bolOpn As Boolean, _
              bolMat As Boolean, _
              lngRow As Long
          On Error Resume Next
          Set excApp = GetObject(, "Excel.Application")
          On Error GoTo 0
          If TypeName(excApp) = "Nothing" Then
              Set excApp = CreateObject("Excel.Application")
          Else
              For Each excWkb In excApp.Workbooks
                  If LCase(excWkb.FullName) = LCase(WKB_PATH) Then
                      bolOpn = True
                      Exit For
                  End If
              Next
          End If
          If Not bolOpn Then
              Set excWkb = excApp.Workbooks.Open(WKB_PATH)
          End If
          Set excWks = excWkb.Worksheets("TestSMS")
          For lngRow = 2 To excWks.UsedRange.rows.Count
              If InStr(1, olkSMS.SenderName, excWks.Cells(lngRow, 4).Value) > 0 Then
                  bolMat = True
                  Exit For
              End If
          Next
          If Not bolMat Then
              lngRow = excWks.UsedRange.rows.Count + 1
          End If
          excWks.Hyperlinks.Add Anchor:=excWks.Range("E" & lngRow), Address:="outlook:" & olkSMS.EntryID, TextToDisplay:="View"
          excWks.Cells(lngRow, 6).Value = olkSMS.ReceivedTime & vbTab & olkSMS.Subject & vbLf & excWks.Cells(lngRow, 6).Value
          If bolOpn Then
              excWkb.Save
          Else
              excWkb.Close True
          End If
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
      
      Sub TestSaveTextMessageToExcel()
          SaveTextMessageToExcel Application.ActiveExplorer.Selection(1)
      End Sub
      
  5. Need help generating an automatic script that will do the following:
    Patients Name would be in one cell. A different cell on the same row. would have the text “no” as default text. When the text is changed to “yes”, a pop-up should appear that asks “are you sure you want to change status of “name” (name text from cell 1) with yes and no choices. If no is clicked data stays the same, If yes is clicked, a yes is entered in the cell and the entire row is hidden.
    Is this possible?

    • Hi, Maria.

      This should do what you described. This code must go in the Sheet object of the sheet containing the data. As written, the code assumes that the name is in column A and the Yes/No is in column C.

      Private Sub Worksheet_Change(ByVal Target As Excel.Range)
          'On the next line, change the column number as needed.
          If Target.Column = 3 And Target.Row > 1 Then
              If LCase(Application.ActiveSheet.Cells(Target.Row, Target.Column).Value) = "yes" Then
                  If MsgBox("Are you sure you want to change the status of " & Application.ActiveSheet.Cells(Target.Row, 1) & "?", vbQuestion + vbYesNo, "Verification") = vbYes Then
                      Rows(Target.Row).EntireRow.Hidden = True
                  Else
                      Application.ActiveSheet(Target.Row, Target.Column).Value = "No"
                  End If
              End If
          End If
      End Sub
      
    • Thank you. With a tiny tweak to one of the lines of the script, works great!
      Another question: If the patient is entered as White, Snow. Is there a way to change the patient’s name on the pop-up to Snow White, with out changing the original cell?

    • Hi, Maria.

      If all the names are entered in the same format, then something like this will work.

      Private Sub Worksheet_Change(ByVal Target As Excel.Range)
          'On the next line, change the column number as needed.
          If Target.Column = 3 And Target.Row > 1 Then
              If LCase(Application.ActiveSheet.Cells(Target.Row, Target.Column).Value) = "yes" Then
                  arrNam = Split(Application.ActiveSheet.Cells(TargetRow,1).Value, ", ")
                  If MsgBox("Are you sure you want to change the status of " & arrName(1) & " " & arrNam(0) & "?", vbQuestion + vbYesNo, "Verification") = vbYes Then
                      Rows(Target.Row).EntireRow.Hidden = True
                  Else
                      Application.ActiveSheet(Target.Row, Target.Column).Value = "No"
                  End If
              End If
          End If
      End Sub
      
    • Hi, Fabio.

      What version of Outlook are you using? Outlook does not keep track of time when you reply to a message. There are a couple of workarounds to get that piece of information. One, find all related messages and figure out which one is a reply to the current message. Two, look at the PR_LAST_VERB_EXECUTED property of the current item. If its value equals reply, then look at the PR_LAST_VERB_EXECUTION_TIME property to get the time. This method is flawed because clicking “Reply” sets the two properties even if you never send the reply.

  6. I’m getting run-time error 1004, on the line “excWks.Cells(intRow, 1) = olkMsg.Subject” on one big inbox folder but on the one smaller ones it’s OK. Any reason why?

  7. Hi would you be able to help with a macro that will take the subject, date and time of an email in a certain folder in outlook 2010 and export that information to an existing excel spreadsheet each time? Thank you!

    • Shana,

      This it a knock-off of rev 2 and should do what you asked for. Follow the instructions from the original post to add the code to Outlook. Please pay attention to the comments in the code.

      '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 Shana)"
       
      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 the Excel 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, _
              intRow As Integer
          If strFilename <> "" Then
              If strFolderPath <> "" Then
                  Set olkFld = OpenOutlookFolder(strFolderPath)
                  If TypeName(olkFld) <> "Nothing" Then
                      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"
                      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.Cells(intRow, 2) = olkMsg.ReceivedTime
                              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
       
      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
      
  8. Hi David,

    I am looking for a macro which extracts the “From” contact for every email sent to a particular email inbox in Outlook – and inputs that into a new excel worksheet each day with time it was sent. Is there a version of your macro above which allows this?

    Would greatly appreciate your help.
    Thanks

    • Hi, HardikNanda.

      I can whip up a version that does this. Do you want to select the folder each time you export or do you want the script to know which folder to export? Same question for the Excel workbook. Do you want to enter a workbook path each time, or would you like the script to create a new workbook in a given folder each time where the script calculates the workbook name? For example, Export 2014-10-17.xlsx for today’s export, Export 2014-10-18 for tomorrow’s?

  9. Hi

    Thanks for excellent script. I use version 7 but I want a function from version 3. I want the subfolder function. Can I just copy some code?

    Thanks
    Edvard

    • Hi, Edvard.

      You’re welcome!

      Here is a version that’s a mashup of revs 3 & 7. Please test it and let me know if this is what you wanted.

      '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 Edvard)"
      
      Dim excApp As Object, _
          excWkb As Object, _
          excWks As Object, _
          intVersion As Integer, _
          intMessages As Integer
      
      Sub ExportMessagesToExcel()
          intVersion = GetOutlookVersion()
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Worksheets(SHEET_NAME)
          ProcessFolder Application.ActiveExplorer.CurrentFolder
          excWkb.Close True
          Set excWks = Nothing
          Set excWkb = Nothing
          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 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
      
    • Hi

      Thanks a lot. It looks it works to 98%. The counter is a little bit strange. I test on my inbox. I have 45 mail, no subfolders and the counter says 550 items, 648 items. It is random.

      Best Regards, Edvard

    • Hi, Edvard.

      The counter isn’t resetting after each run. Add this line of code

          intMessages = 0
      

      immediately before this line of code

          ProcessFolder Application.ActiveExplorer.CurrentFolder
      

      in the subroutine ExportMessagesToExcel.

    • Hi

      It solved the problem.

      Thanks a lot.

      Best Regards, Edvard

      14 okt 2014 kl. 14:38 skrev TechnicLee :

      > >

    • Hello again

      I have two other questions

      Is it possible to get email adress from sender AND receiver (from and to field? It it possible to export the real name (given and surname) on the sender and receiver (from and to field). For example my name is Edvard Wicksell but my mailadress i edvard@hagnestahill.se?

      Thanks again for an excellent site

      Best Regards, Edvard

      14 okt 2014 kl. 12:06 skrev TechnicLee :

      > >

    • Hi, Edvard.

      Yes, it is possible to get the email address of both the sender and receiver. Getting the real name is possible too, but only if one of the following conditions is true

      1. Your mail is on an Exchange server and the sender is in your email domain.
      2. You have a contact entry for the sender.
    • Hi David

      The macro works perfect. I wonder if you can add a field. I want to have TO email address. Is it possible?

      Thanks

      Edvard

      > 14 okt 2014 kl. 12:06 skrev TechnicLee : > >

    • Hi, Edvard.

      Do you want everyone the message was addressed to or only the account the message came to you through? Where in the order of the export do you “To” to appear?

    • Hi

      Everyone the message was addressed to. After from field. I add the script I get from you earlier.

      Best Regards, Edvard

      'On the next line edit the path to the spreadsheet you want to export to 
      Const WORKBOOK_PATH = "c:\temp\test.xlsx" 
      'On the next line edit the name of the sheet you want to export to 
      Const SHEET_NAME = "Sheet2" 
      Const MACRO_NAME = "Export Messages to Excel (Rev Edvard)" 
      
      Dim excApp As Object, _ 
          excWkb As Object, _ 
          excWks As Object, _ 
          intVersion As Integer, _ 
          intMessages As Integer 
      
      Sub ExportMessagesToExcel() 
          intVersion = GetOutlookVersion() 
          Set excApp = CreateObject("Excel.Application") 
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH) 
          Set excWks = excWkb.Worksheets(SHEET_NAME) 
          intMessages = 0 
          ProcessFolder Application.ActiveExplorer.CurrentFolder 
          excWkb.Close True 
          Set excWks = Nothing 
          Set excWkb = Nothing 
          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) = GetSMTPAddress(olkMsg, intVersion) 
                  'excWks.Cells(intRow, 2) = olkMsg.Subject 
                  'excWks.Cells(intRow, 3) = olkMsg.ReceivedTime 
                  intRow = intRow + 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  21 okt 2014 kl. 15:46 skrev TechnicLee : >  >
      
    • Edvard,

      Replace the ProcessFolder subroutine you have now with the version below. Leave the rest of the code as is.

      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) = GetSMTPAddress(olkMsg, intVersion)
                  excWks.Cells(intRow, 2) = olkMsg.To
                  'excWks.Cells(intRow, 2) = olkMsg.Subject
                  'excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                  intRow = intRow + 1
                  intMessages = intMessages + 1
              End If
          Next
          Set olkMsg = Nothing
          For Each olkSub In olkFld.Folders
              ProcessFolder olkSub
          Next
          Set olkSub = Nothing
      End Sub 
      
    • Hi David

      Sorry for my late feedback. Your script works perfect.

      Thanks again.

      Edvard

      > 21 okt 2014 kl. 17:28 skrev TechnicLee : > >

  10. Hi. Thanks for all excelent script. I use version 7 right know but I want the function from revision 3 included (subfolder function). Is it any script for that?

    Thanks
    Edvard

  11. Revision 25 consistently fails with this error

    Run-time error ‘2147467259 (80004005)':
    Automation error
    Unspecified error

    Which is in this function, specifically the set objIE line, I cant seem to make this work. can you assist?

    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

    Regards,
    Robert

    • Hi, Rob.

      What version of IE is on the computer? Also, is IE already open or running in the background?

    • OK I’ve played with this a bit more. the failure appears to have something to do with the number of messages that it processes within the folder. I’ve had it work with as many as 47 messages but after that it fails.

    • Rob,

      If you open Task Manager after it fails, do you see multiple instances of Internet Explorer on the Processes tab?

    • IE version 10. Excel and IE are not running when I run the macro. If it fails with the error they both stay running. I then manually close them before reattempting it. this is how i noticed that based on the m number of the messages in the folder it fails.

    • Rob,

      Try inserting this command

      objIE.Quit
      

      just prior to this line

      Set objLink = Nothing
      

      in the GetLinks function.

      This should cause IE to terminate itself after each pass through that function. Note that if you have any other IE tabs open, then they will close too.

  12. Hi David, I’m using your code sample, and they are great. Thank you. Would it be possible to export all emails in subfolders as PDF files. Our work inbox is running out of space. We have 100+ subfolders for each client. Thanks!

    • Hi, Zac.

      Yes, that’s possible if you employ a third-party tool such as Bullzip PDF Printer. Outlook’s native SaveAs method doesn’t offer the ability to save an item in PDF format. That leaves printing as the only way I know of to do this. For printing to work the solution needs to be able to set the name of the file the item is printed to. Adobe’s PDF printer may have a way to do that from a script, but if it does I’m not familiar with it. I’ve used Bullzip before and I know it works. There are probably other tools out there that offer the same capability that Bullzip does, it just happens to be the one I’m familiar with.

  13. Hi David!

    I must admit that a day on this has fried my brain considerably. I have learnt quite a lot I think, again thanks. What I have been working on is as follows.

    I am trying to track email correspondence with a particular client as part of an ongoing project. I have set up email that copy received emails to folders based on the client names and whether the email was received or sent.

    Every 15 days I want to run a macro that would use one of these folders create an excel spreadsheet with; Date received, From, Subject, To, Cc, Bcc (for sent), Attachment name, ID, Link to body, Link to attachment . I want it to prompt for a date range (the 15 days is fluid) the parent FOLDERNAME, and the FILENAME for the excel file. The message text should be saved by unique ID in a folder ‘FILENAME_emails’ within the parent folder. I would ideally like an attachment prompt – whether to save the actual attachment, as for some users this would not be necessary, but if attachments are to be saved they should be saved in a folder ‘FILENAME_attachments’. Result would therefore look something like
    FOLDERNAME\FILENAME.xlsx ,
    FOLDERNAME\FILENAME_emails\ID.txt ,
    FOLDERNAME\FILENAME_attachments\attachmentname.pdf.

    One of many parts I am having trouble with is trying to figure out the linking so that the link looks for the txt and the attachments from the parent folder, so that the whole parent folder ‘foldername’ could be zipped, uploaded to ftp, downloaded and unzipped, and have the links not broken.

    If you would have the time to assist with this mashup of revs 1,4,5,6,24,29 (amongst others!) it would be greatly appreciated.

    • Hi, David.

      Can you clarify a few things for me? What is “ID” in this context and where is that information coming from? When you say “Link to body” what do you have in mind? Do you mean you want to save the message body to its own file and link to that file? How do you want to handle attachment naming, since it’s possible that there will be more than one attachment with the same name? There’s no way I can think of to link to a file on the local hard drive in such a way that the links would still work should the parent folder be move to another computer. Unless of course the other computer has the exact same folder structure as the source computer.

  14. Hi David,

    Firstly, thank you for an amazing page. I came here looking for one answer and have since experimented with about 20 of the revisions. Fascinating. I have tried to modify some of the revisions; I am trying to keep a report of emails sent to and from a certain domain/series of domains – basically a communications summary. This has been by far the most useful page for getting to where I am now and for that I thank you!

    My ideal solution is a little…ambitious. I would ideally be able to pull the inbox and sent folders, filter for specific email domains from and sent to, and increment to a particular sheet pair (sheet 1 received, sheet 2 sent) with date, time, sender/sendee*, subject, name of any attachments- much the same as whats above. But I would like to do it with multiple accounts, and have it all write to the same report on different sheet pairs.

    I’m going to give it a go over the next week or so, and i am sure I will be coming back to this site regularly to experiment! Many thanks!

    • Hi, David.

      Thanks! I’m glad you’ve found the site helpful.

      What you’ve outlined sounds pretty simple. Revision 1 is very close to what you’ve described. It would allow you to call the export routine once for each mailbox/folder you want to export. It’d be pretty simple to modify it to take extra parameters such as the sheet to write the export to and the list of domains to filter on. The export itself already handles the date/time, sender, and subject. The only mod it would require is a loop to handle the attachments.

  15. Hi Dave,

    I am currently working on implementing Revision 7; and really would like Revision 12 but I can’t seem to get it to work properly.

    I receive emails that have standardized fields (Name:, Company Address; etc.); the user then fills out these fields and emails it to me.

    I have the macro working (revision 7 I think) that opens each email and pulls the information based on each field. However, it simply overwrites the original Excel sheet. Really, I want to run this macro multiple times a day and have the new information added.

    To reach perfection (very similar to Revision 12)
    I would have the emails to be processed in one folder within Outlook “Test Folder”; hit the macro where it reads those emails and moves the data into the Excel spreadsheet on the next available row then moves the email to a “History Folder”

    So after running the Macro; the Test Folder is now empty (ready for more incoming unprocessed emails), the History folder has those original emails (which are now processed) and the Excel spreadsheet has all the information split into it’s fields. So when I run the Macro again with more new emails; the macro simple adds the new email information to the end of the existing (processed) information.

    Does that make any sense?

    Here is the code I am currently using which works perfectly; other than overwriting the Excel file each time rather than just adding to the next available blank space:

    Const WORKBOOK_PATH = "C:\Users\msomekh\Desktop\Test.xlsx"
    Const SHEET_NAME = "Sheet1"
    Const MACRO_NAME = "Export Messages to Excel"
    
     
    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 = "C:\Users\msomekh\Desktop\Test.xlsx"
        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) = "Received"
                .Cells(1, 2) = "Customer Name"
                .Cells(1, 3) = "Customer Phone Number"
                .Cells(1, 4) = "Customer Email Address"
                .Cells(1, 5) = "Company Name"
                .Cells(1, 6) = "Company Address"
                .Cells(1, 8) = "Machine Location"
                .Cells(1, 9) = "Customer Account Number"
                .Cells(1, 10) = "Credit Card Number"
                .Cells(1, 11) = "Credit Card Expiry"
                .Cells(1, 12) = "Credit Card Security Code"
                .Cells(1, 13) = "Machine Name and Type"
                .Cells(1, 14) = "Machine Serial Number"
                .Cells(1, 15) = "Original Purchase Location"
                .Cells(1, 16) = "Original Purchase Date"
                .Cells(1, 17) = "Other Warranty Information"
                .Cells(1, 18) = "Assigned Technician"
                .Cells(1, 19) = "Reported Fault"
                .Cells(1, 20) = "Further Notes"
            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.ReceivedTime
                    strBuffer = ""
                    bolComments = False
                    arrLines = Split(olkMsg.Body, vbCrLf)
                    For Each varLine In arrLines
                        strTemp = Trim(varLine)
                        If bolComments Then
                            strBuffer = strBuffer &amp; strTemp
                        Else
                            If Left(strTemp, 14) = "Customer Name:" Then
                                excWks.Cells(intRow, 2) = Mid(strTemp, 15)
                            Else
                                If Left(strTemp, 22) = "Customer Phone Number:" Then
                                    excWks.Cells(intRow, 3) = Mid(strTemp, 23)
                                Else
                                    If Left(strTemp, 23) = "Customer Email Address:" Then
                                        excWks.Cells(intRow, 4) = Mid(strTemp, 24)
                                    Else
                                        If Left(strTemp, 13) = "Company Name:" Then
                                            excWks.Cells(intRow, 5) = Mid(strTemp, 14)
                                        Else
                                            If Left(strTemp, 16) = "Company Address:" Then
                                                excWks.Cells(intRow, 6) = Mid(strTemp, 17)
                                            Else
                                                If Left(strTemp, 17) = "Machine Location:" Then
                                                    excWks.Cells(intRow, 8) = Mid(strTemp, 18)
                                                Else
                                                    If Left(strTemp, 24) = "Customer Account Number:" Then
                                                        excWks.Cells(intRow, 9) = Mid(strTemp, 25)
                                                    Else
                                                        If Left(strTemp, 19) = "Credit Card Number:" Then
                                                            excWks.Cells(intRow, 10) = Mid(strTemp, 20)
                                                        Else
                                                            If Left(strTemp, 19) = "Credit Card Expiry:" Then
                                                                excWks.Cells(intRow, 11) = Mid(strTemp, 20)
                                                            Else
                                                                If Left(strTemp, 26) = "Credit Card Security Code:" Then
                                                                    excWks.Cells(intRow, 12) = Mid(strTemp, 27)
                                                                Else
                                                                    If Left(strTemp, 22) = "Machine Name and Type:" Then
                                                                        excWks.Cells(intRow, 13) = Mid(strTemp, 23)
                                                                    Else
                                                                        If Left(strTemp, 22) = "Machine Serial Number:" Then
                                                                            excWks.Cells(intRow, 14) = Mid(strTemp, 23)
                                                                        Else
                                                                            If Left(strTemp, 27) = "Original Purchase Location:" Then
                                                                                excWks.Cells(intRow, 15) = Mid(strTemp, 28)
                                                                            Else
                                                                                If Left(strTemp, 23) = "Original Purchase Date:" Then
                                                                                    excWks.Cells(intRow, 16) = Mid(strTemp, 24)
                                                                                Else
                                                                                    If Left(strTemp, 27) = "Other Warranty Information:" Then
                                                                                        excWks.Cells(intRow, 17) = Mid(strTemp, 28)
                                                                                    Else
                                                                                        If Left(strTemp, 20) = "Assigned Technician:" Then
                                                                                            excWks.Cells(intRow, 18) = Mid(strTemp, 21)
                                                                                        Else
                                                                                            If Left(strTemp, 15) = "Reported Fault:" Then
                                                                                                excWks.Cells(intRow, 19) = Mid(strTemp, 16)
                                                                                            Else
                                                                                                If Left(strTemp, 14) = "Further Notes:" Then
                                                                                                    excWks.Cells(intRow, 20) = Mid(strTemp, 15)
                                                                                                End If
                                                                                            End If
                                                                                        End If
                                                                                    End If
                                                                                End If
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            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 " &amp; intRow - 2 &amp; " 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 &lt; 14
                If Item.SenderEmailType = &quot;EX&quot; 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, &quot;.&quot;)
        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(&quot;http://schemas.microsoft.com/mapi/proptag/0x5D01001E&quot;)
        On Error GoTo 0
        Set olkPA = Nothing
    End Function
    
    Sub CallLogTemplate()
        strForm = &quot;IPM.Note.TaraProjectTemplate&quot;
        Set objFolder = Application.ActiveExplorer.CurrentFolder
        Set objItem = objFolder.Items.Add(strForm)
        objItem.Display
    End Sub
    

    Can you please help me?

    • Hi, Matt.

      If I understand correctly, the two issues are how to make the code update an existing spreadsheet instead of creating a new one each time, and moving exported messages to a backup folder. This code implements both of those changes. Please replace the code you have now with this version. Try it out and let me know if it does what you wanted.

      'On the next line, edit the path to the workbook the export is to be written to
      Const WORKBOOK_PATH = "C:\Users\msomekh\Desktop\Test.xlsx"
      'On the next line, edit the path to the worksheet in the workbook the export is to be written to
      Const SHEET_NAME = "Sheet1"
      'On the next line, edit the path to the Outlook folder exported items are to be moved to
      Const BACKUP_FOLDER = "Personal Folders\Backup"
      Const MACRO_NAME = "Export Messages to Excel"
      
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              intRow As Integer, _
              intCnt As Integer, _
              intVersion As Integer, _
              strBuffer As String, _
              strTemp As String, _
              arrLines As Variant, _
              varLine As Variant, _
              bolComments As Boolean
          intVersion = GetOutlookVersion()
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Sheets(SHEET_NAME)
          'Write Excel Column Headers
          With excWks
              .Cells(1, 1) = "Received"
              .Cells(1, 2) = "Customer Name"
              .Cells(1, 3) = "Customer Phone Number"
              .Cells(1, 4) = "Customer Email Address"
              .Cells(1, 5) = "Company Name"
              .Cells(1, 6) = "Company Address"
              .Cells(1, 8) = "Machine Location"
              .Cells(1, 9) = "Customer Account Number"
              .Cells(1, 10) = "Credit Card Number"
              .Cells(1, 11) = "Credit Card Expiry"
              .Cells(1, 12) = "Credit Card Security Code"
              .Cells(1, 13) = "Machine Name and Type"
              .Cells(1, 14) = "Machine Serial Number"
              .Cells(1, 15) = "Original Purchase Location"
              .Cells(1, 16) = "Original Purchase Date"
              .Cells(1, 17) = "Other Warranty Information"
              .Cells(1, 18) = "Assigned Technician"
              .Cells(1, 19) = "Reported Fault"
              .Cells(1, 20) = "Further Notes"
          End With
          intRow = excWks.UsedRange.rows.Count + 1
          Set olkBkp = OpenOutlookFolder(BACKUP_FOLDER)
          'Write messages to spreadsheet
          For intCnt = Application.ActiveExplorer.CurrentFolder.Items.Count To 1 Step -1
              Set olkMsg = Application.ActiveExplorer.CurrentFolder.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.ReceivedTime
                  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, 14) = "Customer Name:" Then
                              excWks.Cells(intRow, 2) = Mid(strTemp, 15)
                          Else
                              If Left(strTemp, 22) = "Customer Phone Number:" Then
                                  excWks.Cells(intRow, 3) = Mid(strTemp, 23)
                              Else
                                  If Left(strTemp, 23) = "Customer Email Address:" Then
                                      excWks.Cells(intRow, 4) = Mid(strTemp, 24)
                                  Else
                                      If Left(strTemp, 13) = "Company Name:" Then
                                          excWks.Cells(intRow, 5) = Mid(strTemp, 14)
                                      Else
                                          If Left(strTemp, 16) = "Company Address:" Then
                                              excWks.Cells(intRow, 6) = Mid(strTemp, 17)
                                          Else
                                              If Left(strTemp, 17) = "Machine Location:" Then
                                                  excWks.Cells(intRow, 8) = Mid(strTemp, 18)
                                              Else
                                                  If Left(strTemp, 24) = "Customer Account Number:" Then
                                                      excWks.Cells(intRow, 9) = Mid(strTemp, 25)
                                                  Else
                                                      If Left(strTemp, 19) = "Credit Card Number:" Then
                                                          excWks.Cells(intRow, 10) = Mid(strTemp, 20)
                                                      Else
                                                          If Left(strTemp, 19) = "Credit Card Expiry:" Then
                                                              excWks.Cells(intRow, 11) = Mid(strTemp, 20)
                                                          Else
                                                              If Left(strTemp, 26) = "Credit Card Security Code:" Then
                                                                  excWks.Cells(intRow, 12) = Mid(strTemp, 27)
                                                              Else
                                                                  If Left(strTemp, 22) = "Machine Name and Type:" Then
                                                                      excWks.Cells(intRow, 13) = Mid(strTemp, 23)
                                                                  Else
                                                                      If Left(strTemp, 22) = "Machine Serial Number:" Then
                                                                          excWks.Cells(intRow, 14) = Mid(strTemp, 23)
                                                                      Else
                                                                          If Left(strTemp, 27) = "Original Purchase Location:" Then
                                                                              excWks.Cells(intRow, 15) = Mid(strTemp, 28)
                                                                          Else
                                                                              If Left(strTemp, 23) = "Original Purchase Date:" Then
                                                                                  excWks.Cells(intRow, 16) = Mid(strTemp, 24)
                                                                              Else
                                                                                  If Left(strTemp, 27) = "Other Warranty Information:" Then
                                                                                      excWks.Cells(intRow, 17) = Mid(strTemp, 28)
                                                                                  Else
                                                                                      If Left(strTemp, 20) = "Assigned Technician:" Then
                                                                                          excWks.Cells(intRow, 18) = Mid(strTemp, 21)
                                                                                      Else
                                                                                          If Left(strTemp, 15) = "Reported Fault:" Then
                                                                                              excWks.Cells(intRow, 19) = Mid(strTemp, 16)
                                                                                          Else
                                                                                              If Left(strTemp, 14) = "Further Notes:" Then
                                                                                                  excWks.Cells(intRow, 20) = Mid(strTemp, 15)
                                                                                              End If
                                                                                          End If
                                                                                      End If
                                                                                  End If
                                                                              End If
                                                                          End If
                                                                      End If
                                                                  End If
                                                              End If
                                                          End If
                                                      End If
                                                  End If
                                              End If
                                          End If
                                      End If
                                  End If
                              End If
                          End If
                      End If
                  Next
                  excWks.Cells(intRow, 7) = strBuffer
                  intRow = intRow + 1
                  olkMsg.Move olkBkp
              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
       
      Sub CallLogTemplate()
          strForm = "IPM.Note.TaraProjectTemplate"
          Set objFolder = Application.ActiveExplorer.CurrentFolder
          Set objItem = objFolder.Items.Add(strForm)
          objItem.Display
      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
      
    • Hi Dave,

      Thank you so much for the code; however, it still needs a little tweaking.

      On line 146 of the code you posted; I am getting a message that says this End IF does not have a starting IF statement to end.

      I tried deleting it but now says that the file (excel) cannot be accessed despite the path being correct.

      I can also only get it to move the emails once processed back to my inbox and it will not move them into a sub-folder within the inbox (inbox\Test History) – message is “Cannot move the items”

      Any ideas on what’s going wrong?

      Many Thanks

      Matt

    • Matt,

      I fixed the first two issues. Please replace the subroutine ExportMessagesToExcel with the one below. Leave the rest fo the code as is. As to the third problem, the path to the folder you want to move exported messages to is almost certainly invalid. A folder path in Outlook is just like a folder path in Windows with the exception of a drive letter. Outlook folder paths don’t have drive letters. The path is the name of each folder from the root to the target, with each level separated from the preceding level by a \. If the target folder is Test History and that folder is under Inbox, then the part that’s missing is the root folder that holds the inbox. Depending on which version of Outlook you’re using, that will be something like “matt@company.com” or “Mailbox – Matt”. Assuming the former, the full path would be something like “matt@company.com\inbox\test history”.

      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              intRow As Integer, _
              intCnt As Integer, _
              intVersion As Integer, _
              strBuffer As String, _
              strTemp As String, _
              arrLines As Variant, _
              varLine As Variant, _
              bolComments As Boolean
          intVersion = GetOutlookVersion()
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Sheets(SHEET_NAME)
          'Write Excel Column Headers
          With excWks
              .Cells(1, 1) = "Received"
              .Cells(1, 2) = "Customer Name"
              .Cells(1, 3) = "Customer Phone Number"
              .Cells(1, 4) = "Customer Email Address"
              .Cells(1, 5) = "Company Name"
              .Cells(1, 6) = "Company Address"
              .Cells(1, 8) = "Machine Location"
              .Cells(1, 9) = "Customer Account Number"
              .Cells(1, 10) = "Credit Card Number"
              .Cells(1, 11) = "Credit Card Expiry"
              .Cells(1, 12) = "Credit Card Security Code"
              .Cells(1, 13) = "Machine Name and Type"
              .Cells(1, 14) = "Machine Serial Number"
              .Cells(1, 15) = "Original Purchase Location"
              .Cells(1, 16) = "Original Purchase Date"
              .Cells(1, 17) = "Other Warranty Information"
              .Cells(1, 18) = "Assigned Technician"
              .Cells(1, 19) = "Reported Fault"
              .Cells(1, 20) = "Further Notes"
          End With
          intRow = excWks.UsedRange.rows.Count + 1
          Set olkBkp = OpenOutlookFolder(BACKUP_FOLDER)
          'Write messages to spreadsheet
          For intCnt = Application.ActiveExplorer.CurrentFolder.Items.Count To 1 Step -1
              Set olkMsg = Application.ActiveExplorer.CurrentFolder.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.ReceivedTime
                  strBuffer = ""
                  bolComments = False
                  arrLines = Split(olkMsg.Body, vbCrLf)
                  For Each varLine In arrLines
                      strTemp = Trim(varLine)
                      If bolComments Then
                          strBuffer = strBuffer & strTemp
                      ElseIf Left(strTemp, 14) = "Customer Name:" Then
                          excWks.Cells(intRow, 2) = Mid(strTemp, 15)
                      ElseIf Left(strTemp, 22) = "Customer Phone Number:" Then
                          excWks.Cells(intRow, 3) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 23) = "Customer Email Address:" Then
                          excWks.Cells(intRow, 4) = Mid(strTemp, 24)
                      ElseIf Left(strTemp, 13) = "Company Name:" Then
                          excWks.Cells(intRow, 5) = Mid(strTemp, 14)
                      ElseIf Left(strTemp, 16) = "Company Address:" Then
                          excWks.Cells(intRow, 6) = Mid(strTemp, 17)
                      ElseIf Left(strTemp, 17) = "Machine Location:" Then
                          excWks.Cells(intRow, 8) = Mid(strTemp, 18)
                      ElseIf Left(strTemp, 24) = "Customer Account Number:" Then
                          excWks.Cells(intRow, 9) = Mid(strTemp, 25)
                      ElseIf Left(strTemp, 19) = "Credit Card Number:" Then
                          excWks.Cells(intRow, 10) = Mid(strTemp, 20)
                      ElseIf Left(strTemp, 19) = "Credit Card Expiry:" Then
                          excWks.Cells(intRow, 11) = Mid(strTemp, 20)
                      ElseIf Left(strTemp, 26) = "Credit Card Security Code:" Then
                          excWks.Cells(intRow, 12) = Mid(strTemp, 27)
                      ElseIf Left(strTemp, 22) = "Machine Name and Type:" Then
                          excWks.Cells(intRow, 13) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 22) = "Machine Serial Number:" Then
                          excWks.Cells(intRow, 14) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 27) = "Original Purchase Location:" Then
                          excWks.Cells(intRow, 15) = Mid(strTemp, 28)
                      ElseIf Left(strTemp, 23) = "Original Purchase Date:" Then
                          excWks.Cells(intRow, 16) = Mid(strTemp, 24)
                      ElseIf Left(strTemp, 27) = "Other Warranty Information:" Then
                          excWks.Cells(intRow, 17) = Mid(strTemp, 28)
                      ElseIf Left(strTemp, 20) = "Assigned Technician:" Then
                          excWks.Cells(intRow, 18) = Mid(strTemp, 21)
                      ElseIf Left(strTemp, 15) = "Reported Fault:" Then
                          excWks.Cells(intRow, 19) = Mid(strTemp, 16)
                      ElseIf Left(strTemp, 14) = "Further Notes:" Then
                          excWks.Cells(intRow, 20) = Mid(strTemp, 15)
                      End If
                  Next
                  excWks.Cells(intRow, 7) = strBuffer
                  intRow = intRow + 1
                  olkMsg.Move olkBkp
              End If
              Next
              Set olkMsg = Nothing
              excWkb.clsoe True
          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
      
    • Hi Dave,

      Thanks again. Still no success.

      I copied and pasted the subroutine and replaced only the subroutine (leaving everything else from your original code constant but it is still coming up with a compile error: “End If without block If”

      I ran this process three times (copying and pasting; wipe the whole slate clean and starting with your original code; running it then replacing the subroutine with the new one)

      Any ideas?

      Many Thanks

      Matt

    • Matt,

      Please try this version. Once again please just replace the subroutine of the same name as the one below. Please leave everything else as is.

      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              intRow As Integer, _
              intCnt As Integer, _
              intVersion As Integer, _
              strBuffer As String, _
              strTemp As String, _
              arrLines As Variant, _
              varLine As Variant, _
              bolComments As Boolean
          intVersion = GetOutlookVersion()
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Sheets(SHEET_NAME)
          'Write Excel Column Headers
          With excWks
              .Cells(1, 1) = "Received"
              .Cells(1, 2) = "Customer Name"
              .Cells(1, 3) = "Customer Phone Number"
              .Cells(1, 4) = "Customer Email Address"
              .Cells(1, 5) = "Company Name"
              .Cells(1, 6) = "Company Address"
              .Cells(1, 8) = "Machine Location"
              .Cells(1, 9) = "Customer Account Number"
              .Cells(1, 10) = "Credit Card Number"
              .Cells(1, 11) = "Credit Card Expiry"
              .Cells(1, 12) = "Credit Card Security Code"
              .Cells(1, 13) = "Machine Name and Type"
              .Cells(1, 14) = "Machine Serial Number"
              .Cells(1, 15) = "Original Purchase Location"
              .Cells(1, 16) = "Original Purchase Date"
              .Cells(1, 17) = "Other Warranty Information"
              .Cells(1, 18) = "Assigned Technician"
              .Cells(1, 19) = "Reported Fault"
              .Cells(1, 20) = "Further Notes"
          End With
          intRow = excWks.UsedRange.rows.Count + 1
          Set olkBkp = OpenOutlookFolder(BACKUP_FOLDER)
          'Write messages to spreadsheet
          For intCnt = Application.ActiveExplorer.CurrentFolder.Items.Count To 1 Step -1
              Set olkMsg = Application.ActiveExplorer.CurrentFolder.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.ReceivedTime
                  strBuffer = ""
                  bolComments = False
                  arrLines = Split(olkMsg.Body, vbCrLf)
                  For Each varLine In arrLines
                      strTemp = Trim(varLine)
                      If bolComments Then
                          strBuffer = strBuffer & strTemp
                      ElseIf Left(strTemp, 14) = "Customer Name:" Then
                          excWks.Cells(intRow, 2) = Mid(strTemp, 15)
                      ElseIf Left(strTemp, 22) = "Customer Phone Number:" Then
                          excWks.Cells(intRow, 3) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 23) = "Customer Email Address:" Then
                          excWks.Cells(intRow, 4) = Mid(strTemp, 24)
                      ElseIf Left(strTemp, 13) = "Company Name:" Then
                          excWks.Cells(intRow, 5) = Mid(strTemp, 14)
                      ElseIf Left(strTemp, 16) = "Company Address:" Then
                          excWks.Cells(intRow, 6) = Mid(strTemp, 17)
                      ElseIf Left(strTemp, 17) = "Machine Location:" Then
                          excWks.Cells(intRow, 8) = Mid(strTemp, 18)
                      ElseIf Left(strTemp, 24) = "Customer Account Number:" Then
                          excWks.Cells(intRow, 9) = Mid(strTemp, 25)
                      ElseIf Left(strTemp, 19) = "Credit Card Number:" Then
                          excWks.Cells(intRow, 10) = Mid(strTemp, 20)
                      ElseIf Left(strTemp, 19) = "Credit Card Expiry:" Then
                          excWks.Cells(intRow, 11) = Mid(strTemp, 20)
                      ElseIf Left(strTemp, 26) = "Credit Card Security Code:" Then
                          excWks.Cells(intRow, 12) = Mid(strTemp, 27)
                      ElseIf Left(strTemp, 22) = "Machine Name and Type:" Then
                          excWks.Cells(intRow, 13) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 22) = "Machine Serial Number:" Then
                          excWks.Cells(intRow, 14) = Mid(strTemp, 23)
                      ElseIf Left(strTemp, 27) = "Original Purchase Location:" Then
                          excWks.Cells(intRow, 15) = Mid(strTemp, 28)
                      ElseIf Left(strTemp, 23) = "Original Purchase Date:" Then
                          excWks.Cells(intRow, 16) = Mid(strTemp, 24)
                      ElseIf Left(strTemp, 27) = "Other Warranty Information:" Then
                          excWks.Cells(intRow, 17) = Mid(strTemp, 28)
                      ElseIf Left(strTemp, 20) = "Assigned Technician:" Then
                          excWks.Cells(intRow, 18) = Mid(strTemp, 21)
                      ElseIf Left(strTemp, 15) = "Reported Fault:" Then
                          excWks.Cells(intRow, 19) = Mid(strTemp, 16)
                      ElseIf Left(strTemp, 14) = "Further Notes:" Then
                          excWks.Cells(intRow, 20) = Mid(strTemp, 15)
                      End If
                  Next
                  excWks.Cells(intRow, 7) = strBuffer
                  intRow = intRow + 1
                  olkMsg.Move olkBkp
              End If
              Set olkMsg = Nothing
              excWkb.close True
          Next
          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
      
    • Hi Dave,

      I feel we are so close!

      Run-time error: 424

      Object Required

      Debug: Line 48

      I corrected a spelling mistake on line 99 (“clsoe” instead of “close”) but still have the object required message.

      I also noticed that there is another macro in there that I accidentally included on my original post “Taraproject.template”. This is a separate macro that is irrelevant and will be utilized separately. I don’t believe that it makes any difference either way.

      Many Thanks

      Matt

    • Matt,

      I’m guessing that this is line 48.

      Set olkBkp = OpenOutlookFolder(BACKUP_FOLDER)
      

      if so, then my guess is that the path to the folder you want to move the items to is not valid. If that’s not line 48, then what is line 48 at your end?

    • Hi Dave,

      No, I have sorted the path of which to move the files.

      Line 48 is from your last post:

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

      As every time I run the macro and it doesn’t work; it locks up Excel and I need to restart the computer to ensure a clean slate to try again with. Not sure if that means anything but I thought I should include it as an observation.

      Many Thanks

      Matt

    • Matt,

      It’s hard to imagine how you could be getting an “Object Required” error on that line. For that error to occur there either the spreadsheet object (i.e. excWks) is empty (which would imply a problem opening Excel) or the Outlook message object (i.e. olkMsg) is empty. There’s also no reason why Excel should “lock up” and force a reboot. At worst you’d have to use Task Manager to kill the Excel process. Let’s start with the assumption that this is related to Excel. Add this line of code

      excApp.Visible = True
      

      immediately after

      Set excApp = CreateObject("Excel.Application")
      

      Now when you run the macro Excel will become visible. This will allow you to see an error if Excel is having problems.

    • Hi Dave,

      Thanks so much and sorry for my delayed response.

      I placed in those two pieces of code and I am now getting a run error:

      Automation error
      The object invoked has disconnected from it’s client

      Excel does open for a second (a mere flash really), so does not offer any avenues for problem checking.

      To clarify, Excel will lock-up to the point where I have to use Task Manager to end the process. The whole system is not affected. Before using the task manager, I attempt to open the excel file referenced and get a response that this file is already opened but I cannot see it; hence having to kill the process via task manager.

      I am thinking that perhaps I am asking a little too much on the automation side and perhaps a more simple version may be required.

      So far, I have got the code working by exporting the data to Excel. If we go back to basics a little here; by removing the feature of moving the exported emails anywhere with Outlook and simply being able to export the emails to an existing workbook and simply add the email information to the next available spare line, could that make it easier?

      Still maintaining the fields in the emails of what to look for. Does that make any sense?

      Many Thanks

      Matt

    • Hi, Matt.

      You aren’t asking “too much on the automation side”. I’ve written dozens of macros that open and write to Excel and have never run into what you’re describing. Something is happening with Excel that I don’t yet understand. Let’s see if we can figure out what’s happening. First, please tell me what version of Microsoft Office you’re using and whether it’s the 32-bit or 64-bit version. Second, what version of Windows are you using and is it the 32-bit or 64-bit version? Next, let’s do some debugging. Please add the following code to Outlook. Please add the code in the same module with the code you already have. With the code in place, please run MattDebug and tell me what happens.

      Sub MattDebug()
          Dim excApp As Object, _
              excWkb As Object, _
              excWks As Object
          Set excApp = CreateObject("Excel.Application")
          excApp.Visible = True
          Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
          Set excWks = excWkb.Sheets(SHEET_NAME)
      End Sub
      
    • Hi Dave,

      I am using Windows 7 Pro 64-bit with Office 2010 (32-bit).

      I entered the subroutine into code and ran the macro.

      I have entered the path to move the processed emails as: myemailaddress\Inbox
      This is the only thing I can do to get the macro to show some indications of working.

      The emails are in a folder within the Inbox named: “TestCallLogFolder”

      I had originally planned to have the non-processed emails in this folder then planned for them to be moved to a processed folder named “TEST History” (path: myemailaddress\Inbox\TEST History) but this comes up with the error of cannot move items and highlights the “olkMsg.Move olkBkp” code as you had suspected.

      However, when I do change the path to move to “myemailaddress\Inbox”; the macro will run; flashes up Excel with only one entry (roughly 8 rows down from the headers) then closes it and comes up with an error message:
      “Run-time Error: 430
      Class does not support Automation or does not support expected interface”

      I hope that helps?

      Many Thanks

      Matt

    • Hi Dave,

      Excel did appear for a split second (long enough to see that the macro had only placed one entry and it was in the middle/half way down the blank-sheet) before disappearing and coming up with the error message that I last described: “Run-time Error: 430
      Class does not support Automation or does not support expected interface”

      or the message that I just got:

      “Run-time Error: Automation Error – the object has disconnected from it’s clients”

      It appears to give either one of these message each time I try to run the Macro.

      Matt

    • Matt,

      But that’s where I’m confused. The debugging macro I sent doesn’t do anything except open Excel. It doesn’t export anything and from your answer it appears that exporting is taking place. That makes me think that you ran the original macro, not the debugging one I just sent.

    • Hi Dave,

      Sorry my mistake. I included the code into the original but just ran it as a test rather than choosing the specific macro to run.

      So I just ran the debug macro and it opened the Excel sheet (stayed open this time) with only 1 entry on the 23rd row down with nothing else.

      What is next in the investigation process?

      Matt

    • Matt,

      First, I’d like you to create a test folder and put one message in it. I’d then like you to try running the code, the full version, not the debug code, against that folder. If the code fails, I’d then like you to run the code again, this time using the debugger to step through the code one line at a time to the point just before the line it fails on. I’m particularly interested to see if the variable holding the Outlook folder is empty or not.

    • Hi Dave,

      OK, so I have run a series of tests with only one test message in the staring folder:

      Test 1 – Backup folder is set to: myemailaddress\Inbox
      1. Run Macro – Export to Excel
      2. Excel flashed up with the 1 entry at row 26 of the worksheet and then disappeared
      3. The test message within Outlook has been moved from the beginning folder to the Inbox
      4. Dialog box: Process complete. A total of 22 messages were exported

      Test 2 – Backup is set to myemailaddress\Inbox\TEST History
      1. Run Macro – Export to Excel
      2. Excel opens and stays open with 1 entry (row 26)
      3. The test message has not moved out of the original folder
      4. Run-time error: Cannot move items

      Test 3 – Backup is set to emailaddress\Inbox\TEST History
      1. Run Macro via the debug tool as “step into” (F8)
      2. Excel opens and stays open with 1 entry (row 26 from top headers)
      3. The Macro loops 3 times at “Select Case bolBeyondRoot”
      4. Loops 36 times at “strTemp = Trim(varLine)
      5. Per loop, it loops the whole set of fields to look for between “strTemp = Trim(varLine)” and “Next” but on every second loop, it only will go down to each field line then jump to “Next”; loop the whole field set again; then loop to the next field down (“Customer Name”; then loop the whole set; then loop to the next field “Customer Phone Number” etc. until it has loop the whole set 18 times plus looping over each field.
      6. Macro then continues on and stops at “olkMsg.Move olkBkp”
      Run-time Error: Cannot move items.
      7. Message has not moved from original folder

      So what is next?

      Many Thanks

      Matt

    • Hi, Matt.

      If I understand correctly, everything worked correctly in test 1. If so, then the difference between test 1 and tests 2 and 3 is the folder the macro is running against. What is the constant called BACKUP_FOLDER set to? Is it possible that it’s pointing to the same folder the macro is reading from?

    • Hi Dave,

      The emails to be processed are in a folder called “TestCallLogFolder”, the path is:
      myemailaddress@company\Inbox\TestCallLogFolder

      The BACKUP FOLDER in the macro code is set to folder “TEST History”, the path is:
      myemailaddress@company\Inbox\TEST History
      or
      myemailaddress@company\TEST History

      I have tried both and neither will work (comes up with the error of cannot move items).

      Whereas, when I set the BACKUP FOLDER to something basic like:
      myemailaddress@company\Drafts

      The macro comes up with one of two errors:
      Class does not support Automation or does not supported expected interface
      or
      Automation Error: The object invoked has disconnected from its clients

      Matt

    • Hi, Matt.

      Sorry for the long delay in responding.

      Let’s try this. Add the following code to the code you already have.

      Public Sub DisplayFolderPath()
          MsgBox "The path to the currently selected folder is " & vbCrLf & vbCrLf & Application.ActiveExplorer.CurrentFolder.FolderPath, vbInformation + vbOKOnly, "Display Folder Path"
      End Sub
      

      Once you’ve added the code, select the folder named “TestCallLogFolder” and then run the macro DisplayFolderPath. Jot down the folder path. Now select the “TEST History” folder and run the DisplayFolderPath macro again. Jot down this folder path too. Do both folder paths match the paths you’re using in the code?

    • Hi David,

      OK, I ran the display folder path subroutine:

      Problem discovered!

      I had names the TEST History folder as “TEST Histoy” instead of “TEST History”

      Oh dear, simple stuff!!!

      So now that that is fixed,

      What is next?

      When I make the corrections, I am still getting a runtime error:

      The first message from the “TestCallLogFolder” is read and exported to the excel sheet but 25 rows down from the top.

      Outlook does move this first message to the back-up folder: “TEST History”

      but then stops with the runtime error of:
      ‘-2147417848 (80010108)':
      Automation error
      The object invoked has disconnected from its clients.

      When debugged:
      It highlights the
      excWks.Cells(intRow, 1) = olkMsg.ReceivedTime

      One step closer to success?

      Many Thanks

      Matt

    • Hi Dave,

      No, the excel workbook was not open.

      So I have played around with it a bit more.

      So here is what is happening:

      1. With my test folder selected within Outlook (TestCallLogFolder); I run the macro.
      2. The Excel file opens briefly and displays that a message has been copied across (to the next available line down – this now works)
      3. I then get a run-time error
      4. Each time I run the macro (as there are 10 different test messages within the test folder); it will only move one message at a time and each time, I get one of two error messages:

      Either:
      Run-time Error ‘430’:
      Class does not support Automation or does not support expected interface

      Or:
      Run-time Error ‘-2147417848 (80010108)':
      Automation error
      The object invoked has disconnected from its clients.

      Everything else appears to be working (exports the email to the Excel in the right place and moves said email to the other history folder within Outlook). If we could just get it to do all of the messages in one go.

      Many Thanks

      Matt

    • Hi, Matt.

      I run the same code here and it works every time, to include processing multiple messages in a single run. There’s something different at your end. Is it alright if I email you?

  16. David this thread is AMAZING to a newbie like me. Thank you so much for helping so many people with nearly 50 revisions to your original post. If I could glean some advance from you I would be forever grateful. This is my first adventure into VBA and VBScript

    Since finding this blog post 4 days ago I have tried to merge a few of the revisions hoping to accomplish what I need them to do. I’m trying to merge and edit the following into what I need:
    Rev 7 – Append existing sheet (I need it at the top though)
    Rev 10 – Only pulls from today’s date
    Rev 14 – Pulls info from body
    Rev 13 – Run as a scheduled event so I’m messing with it by reading your notes from this one.

    My scenario is like this:
    Part one –
    Email received to alert work has begun
    Email received to alert work has been completed

    Part two –
    Emails have info I need to be exported to an excel
    1 — Subject
    2 — Received time
    3 — Status found to the left of “QA review: ”
    —— Ex: QA review: Started
    4 — Word found to the left of “Issues: ”
    —— Ex. Issues: three

    Part three –
    Parsed inf is appended to the top of the same excel sheet

    Part four –
    Excel list needs to be sent daily to my director

    — Again, thank you for everything you’ve done so far to help newbie like myself understand the mysterious world of this code.

    • Hi, Bud.

      If I’ve correctly understood your requirements, then this should do it. Please give this solution a try and let me know if that’s what you wanted. Follow the instructions for rev 13 to use the code. Please be sure to edit the constants at the top of the code per my comments.

      'On the next line, edit your manager's email address
      Const MANAGER_EMAIL = "someone@company.com"
      'On the next line, edit the subject of the message sent to your manager each day
      Const MANAGER_SUBJECT = "Daily Report"
      'On the next line, edit the body of the message sent to your manager each day
      Const MANAGER_BODY = "Here is my daily report."
      Const MACRO_NAME = "Export Messages to Excel (Rev Bud)"
      Const olMailItem = 0
      Const olMail = 43
       
      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 Excel Workbook", "Name of Sheet Within Excel Workbook", "Path to Outlook Folder"
      ExportMessagesToExcel "c:\users\david\documents\testarea\bud.xlsx", "Data", "Mailbox \Inbox"
      MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
      WScript.Quit
       
       
      Sub ExportMessagesToExcel(strFilename, strSheet, strFolderPath)
          Dim olkMsg, olkFld, olkFlt, intRow, strTmp
          If strFilename <> "" Then
              If strFolderPath <> "" Then
                  Set olkApp = CreateObject("Outlook.Application")
                  Set olkSes = olkApp.GetNamespace("MAPI")
                  olkSes.Logon olkApp.DefaultProfileName
                  Set olkFld = OpenOutlookFolder(strFolderPath)
                  If TypeName(olkFld) <> "Nothing" Then
                      Set excApp = CreateObject("Excel.Application")
                      Set excWkb = excApp.Workbooks.Open(strFilename)
                      Set excWks = excWkb.Sheets(1)
                      Set olkFlt = olkFld.Items.Restrict("[ReceivedTime] >= '" & OutlookDateFormat(Date & " 0:01am") & "' AND [ReceivedTime] < '" & OutlookDateFormat(Date & " 11:59pm") & "'")
                      'Write messages to spreadsheet
                      For Each olkMsg In olkFlt
                          'Only export messages, not receipts or appointment requests, etc.
                          If olkMsg.Class = olMail Then
                          	excWks.Rows(2).Insert
                      		intRow = 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
                              strTmp = FindString(olkMsg.Body,"QA review: (.+)\b")
                              strTmp = Replace(strTmp,"QA review: ","")
                              excWks.Cells(intRow, 3) = strTmp
                              strTmp = FindString(olkMsg.Body,"Issues: (.+)\b")
                              strTmp = Replace(strTmp,"Issues: ","")
                              excWks.Cells(intRow, 4) = strTmp                        
                          End If
                      Next
                      Set olkMsg = Nothing
                      excWks.Columns("A:D").AutoFit
                      excWkb.Close True
                      Set olkMsg = olkApp.CreateItem(olMailItem)
                      With olkMsg
                          .To = MANAGER_EMAIL
                          .Subject = MANAGER_SUBJECT
                          .Body = MANAGER_BODY
                          .Attachments.Add strFilename
                          .Send
                      End With
                  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
       
      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
      
      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
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & "|"
          Next
          If Len(FindString) > 0 Then
              FindString = Left(FindString, Len(FindString) - 1)
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
      
    • David,
      Thank you for such well written explanations. I will implement that shortly.

      This is a great blog. I feel like a hungry kid at the buffet table. I can’t wait to learn everything I can from you. Most people I work with only wish they had the answers. I enjoy the chase to find them and in reading your replies and code I see I can learn a lot here.

      Thank you again,
      Bud

    • David it works great!

      I’m going to learn how to title the columns by looking at the other versions. Thank you so much for taking the time to share the knowledge!

    • Hi David,
      The script works great, but I’m having a problem. Do I need to edit some part for it to have it parse that info for the day it was executed? Currently every time I run it the script exports data from only the first date I implemented it, which was the 23rd. I haven’t had success exporting data from yesterday (24th) or any test data this morning.

      I’m trying to sort it out myself, but I have a feeling you might have an idea.

      Thank you again for being such a great help to everyone.

    • Hi, Bud.

      That’s odd. No, there’s nothing for you to edit in the code. This is the line that controls which messages the script processes. It’s using VBscript’s built-in “Date” function which always returns today’s date. Today it will return 9/25/14. Tomorrow it will return 9/26/14. I don’t see how it could pull messages from the 23rd except on the 23rd.

      Set olkFlt = olkFld.Items.Restrict("[ReceivedTime] >= '" & OutlookDateFormat(Date & " 0:01am") & "' AND [ReceivedTime] < '" & OutlookDateFormat(Date & " 11:59pm") & "'")
      
    • Thank you, I’m sure it’s some simple mistake i’m unaware I’ve made. I love learning all about this. So many things I want to try and your revisions are a lot of help. I’ll keep working on it.

      Thanks again,
      B.

    • Hi David,
      I still enjoy learning from your blog. Thank you for being so active in your replies. If you could, please help me figure this out. I’ve been trying with no luck.

      My original requirement above was to pull the following:
      1 — Subject
      2 — Received time
      3 — Status found to the right of “QA review: ”
      —— Ex: QA review: Started
      4 — Word found to the right of “Issues: ”
      —— Ex. Issues: three

      It works great!
      Now I also need to pull new pieces like this:
      5 — Word(s) found to the right of “Review Type: ”
      6 — Linked text
      7 — The url linked to the text

      Example of 6 and 7 would be text like ‘Google link here’ in the email that is linked to http://www.google.com. It would be totally fine if they exported as they appeared (linked text) if it’s easier than parsing it as two things.

      Something that just occurred to me, since it can pull text that follows spots like “Issues: ” is it just as easy to grab the name that appears at the start. Which is to the left of the word ‘commented’ like this? –

      Bud Herz commented on the topic:
      Ready for QA (<< linked text)
      QA review: Passed
      Issues: None
      Time: .5h

      —————————————–

      Thank you so much for your time!

    • Hi, Bud.

      Good to hear from you again.

      Are the words to the right of “Review Type:” all on the same line with the text “Review Type:”? Are there any other links in the body other than the one you want?

    • 1) Are the words to the right of “Review Type:” all on the same line with the text “Review Type:”?
      —– Yep I’ve got the whole team formatting replies this way while trying to solve it myself, haha.
      Example would be like “Review Type: Automation”

      2) Are there any other links in the body other than the one you want?
      —– There is a link in the footer to ‘suppress emails’ (like an unsubscribe). If it helps to identify and exclude this Suppress link, it always follows a line listing who it’s sent to saying “This message was sent to” So a more complete example of our emails looks like this –

      Project: XX_XXXX_XXXXX
      —————————————————————–
      Bud Herz commented on the topic:
      Ready for QA (<< linked text)
      QA review: Passed
      Issues: None
      Time: .5h
      Review Type: Automation
      ___________________________________________
      This message was sent to Bud Herz Jr.,

      Suppress emails for this thread. (<<< That other link)
      ____________________________________________

      In the example above, the line "Ready for QA" is always a link to harvest. The words may change, but it's always the link we need.

      It is also always part of the subject line that you've so kindly helped with before. This means we really only need to get the url from it and not the actual words. I can tell you it is always in that format. It's always the next line following "XXX XXXX commented on the topic:"

      Thank you so much for the help!

    • Hi David,

      I’ve gotten this far along with it. I can get the columns created and export the “Time:” info for example. I’m sure I can add the “Review Type:”

      I’ve added a column called “Link” for the url, but haven’t figured out how to pull it yet. Here’s what I have –

      ‘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
      strTmp = FindString(olkMsg.Body,”QA review: (.+)\b”)
      strTmp = Replace(strTmp,”QA review: “,””)
      excWks.Cells(intRow, 3) = strTmp
      strTmp = FindString(olkMsg.Body,”Issues: (.+)\b”)
      strTmp = Replace(strTmp,”Issues: “,””)
      excWks.Cells(intRow, 4) = strTmp
      strTmp = FindString(olkMsg.Body,”Link: (.+)\b”)
      strTmp = Replace(strTmp,”Link: “,””)
      excWks.Cells(intRow, 5) = strTmp
      strTmp = FindString(olkMsg.Body,”Time: (.+)\b”)
      strTmp = Replace(strTmp,”Time: “,””)
      excWks.Cells(intRow, 6) = strTmp
      strTmp = FindString(olkMsg.Body,”Review Type: (.+)\b”)
      strTmp = Replace(strTmp,”Time: “,””)

      I get all confident messing with this part and then I’m put back in my place when I feel it must be as easy to edit the date range piece. That’s when the code kicks me in the head and says “Ha!, you don’t know anything mister”.

      I’m envious of your skills.

      I’ve played with the code in Rev 25 to see if I could reverse engineer it, but I’m not having much luck.

    • Hi, Bud.

      Apologies for not having responded sooner. Could you supply me with an actual email that I could use to work out the details? If you can, then I’ll email you and you can reply with teh sample message attached.

    • Absolutely! I totally understand you might have a life outside of answering these. No worries.

      I just sent it to your earthlink address. I hope that is convenient enough for you.

  17. Hello.
    I need to apply the rev. 14 to extract data from emails, but its showing error all the time. do i need to include the 1st code in the beginning of the post with rev.14 to make it work ?? or i should make new macro with the rev.14 only ??

    And thanks alot for this great effort, i couldn’t find place on the internet like you :)

    • Hi, Reda Ahmed.

      Each revision is self-contained, so no, you don’t need the code from the original post. You only need the code from rev 14. What is the error message and what line is it occurring on?

    • Hi, Reda Ahmed.

      If I correctly understood your requirements, then this solution should work for you. Please test it and let me know if it does what you need.

      Const MACRO_NAME = "Export Messages to Excel (Rev Reda Ahmed)"
       
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long, _
              intVer As Integer, _
              strFil As String, _
              strTmp As String, _
              arrLns As Variant, _
              varLin As Variant
          strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
          If strFil <> "" Then
              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) = "Name"
                  .Cells(1, 5) = "Surname"
                  .Cells(1, 6) = "Email"
                  .Cells(1, 7) = "Phone"
                  .Cells(1, 8) = "Time"
                  .Cells(1, 9) = "Office"
              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, intVer)
                      arrLns = Split(olkMsg.Body, vbCrLf)
                      For Each varLin In arrLns
                          strTmp = Trim(varLin)
                          If Left(strTmp, 6) = "Name: " Then
                              excWks.Cells(lngRow, 4) = Mid(strTmp, 7)
                          Else
                              If Left(strTmp, 10) = "Surname: " Then
                                  excWks.Cells(lngRow, 5) = Mid(strTmp, 11)
                              Else
                                  If Left(strTmp, 7) = "Email: " Then
                                      excWks.Cells(lngRow, 6) = Mid(strTmp, 8)
                                  Else
                                      If Left(strTmp, 7) = "Phone: " Then
                                          excWks.Cells(lngRow, 7) = Mid(strTmp, 8)
                                      Else
                                          If Left(strTmp, 6) = "Time: " Then
                                              excWks.Cells(lngRow, 8) = Mid(strTmp, 7)
                                          Else
                                              If Left(strTmp, 8) = "Office: " Then
                                                  excWks.Cells(lngRow, 9) = Mid(strTmp, 9)
                                              End If
                                          End If
                                      End If
                                  End If
                              End If
                          End If
                      Next
                      lngRow = lngRow + 1
                      lngCnt = lngCnt + 1
                  End If
              Next
              Set olkMsg = Nothing
              excWks.Columns("A:I").AutoFit
              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, "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
      
  18. Hello David,

    First of all, with honor I would like to appreciate your dedicated commitment to help those who are in need in a good programming solutions to their every day lives.

    Well, I am in fact one of them too. I can modify VBA language to suit my needs but would never be able to start one from scratch. Anyways …

    I have two email accounts in my outlook (Office 2013). The second one is solely dedicated to receive certain messages. I want those messages to be exported to MS Excel. And this will be a regular routine, I will probably assign a button for it.

    All I need just email body, no sender, no date, no recipient information. I did try a few version you had put together but I cannot get it to work. When I open VBA window in Outlook, how do I assign a macro to that specific PST file? Can you please help me with that?

    Thanking you in advance,
    AliNiz

    • Hi, AliNiz.

      Thank you!

      Here’s a revision that should do what you described. Please test it out and let me know if it does what you asked for.

      'On the next line, edit the path to the Outlook folder you want to export from.
      Const TARGET_FOLDER = "mailbox\folder\folder"
      'ON the next line, edit tha path to the Excel workbook you want to export to.
      Const EXCEL_WORKBOOK = "c:\users\david\documents\testarea\aliniz.xlsx"
      Const MACRO_NAME = "Exports Messages to Excel (rev AliNiz)"
      
      Sub ExportMessagesToExcel()
          Dim olkFld As Outlook.MAPIFolder, _
              olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long
              
          Set olkFld = OpenOutlookFolder(TARGET_FOLDER)
          Select Case TypeName(olkFld)
              Case "Empty", "Nothing"
                  MsgBox "The folder " & TARGET_FOLDER & " does not exist.  Export cancelled.", vbCritical + vbOKOnly, MACRO_NAME
              Case Else
                  Set excApp = CreateObject("Excel.Application")
                  Set excWkb = excApp.Workbooks.Open(EXCEL_WORKBOOK)
                  Set excWks = excWkb.Sheets(1)
                  lngRow = excWks.UsedRange.rows.Count + 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
                          excWks.Cells(lngRow, 1) = olkMsg.Body
                          lngRow = lngRow + 1
                          lngCnt = lngCnt + 1
                      End If
                  Next
                  Set olkMsg = Nothing
                  excWkb.Close True
                  MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
          End Select
          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
      
    • David,

      Before we go further on this, I forgot to mention one more minor criteria: to perform the export of selected messages only – it can be one message or multiple messages.

      Thank you.

    • AliNiz,

      No problem. Use this code instead

      'ON the next line, edit tha path to the Excel workbook you want to export to.
      Const EXCEL_WORKBOOK = "c:\users\david\documents\testarea\aliniz.xlsx"
      Const MACRO_NAME = "Exports Messages to Excel (rev AliNiz)"
       
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long
               
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(EXCEL_WORKBOOK)
          Set excWks = excWkb.Sheets(1)
          lngRow = excWks.UsedRange.rows.Count + 1
          '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
                  excWks.Cells(lngRow, 1) = olkMsg.Body
                  lngRow = lngRow + 1
                  lngCnt = lngCnt + 1
              End If
          Next
          Set olkMsg = Nothing
          excWkb.Close True
          MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
      
    • David,

      It worked great, but is there a way to put each line of the message body in separate rows? Normally, the lines are considerably short but that will serve the purpose of exporting the messages to excel as the messages will be worked out in that file.

      Thank you again good sir!

    • AliNiz,

      Yes, that’s doable. Replace the code you have now with this version.

      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long, _
              arrLin As Variant, _
              varLin As Variant
                
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(EXCEL_WORKBOOK)
          Set excWks = excWkb.Sheets(1)
          lngRow = excWks.UsedRange.rows.Count + 1
          '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
                  arrLin = Split(olkMsg.Body, vbCrLf)
                  For Each varLin In arrLin
                      excWks.Cells(lngRow, 1) = varLin
                      lngRow = lngRow + 1
                  Next
                  lngCnt = lngCnt + 1
              End If
          Next
          Set olkMsg = Nothing
          excWkb.Close True
          MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
      End Sub
      
  19. Hi, i found this topic very usefull! Unfortunally, i couldn’t modify a version to satisfy my necessity (i’m not a good programmer). Let me explain what i need.

    I have a script who send’s me an email if a server is down. in the message body, i have the following message “Machine xpto is out”
    I need to export this message to excel, i want to do some statistics of each server, if i could get the time of email could me fine too.

    thanks, and i hope you can help me

    best regards
    Richard

    • Hi, Richard.

      I can help with that. I’m assuming that the server name varies from message to message. If so, then I’m assuming the line you want is

      Machine SERVER_NAME is out

      where SERVER_NAME is the name of the server. If that’s correct, then I can manage this easily enough.

    • Replied in the wrong place, but, yes David, you’re right!! the server name changes, and it’s like you said, machine SERVER_NAME is out. Thanks in advance

    • Richard,

      Please try this version and let me know if that’s what you wanted. It will only export those messages that have the string “Machine x is out” in the body.

      Const MACRO_NAME = "Exports Messages to Excel (rev Richard)"
      
      Sub ExportMessagesToExcel()
          Dim olkMsg As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long, _
              intVer As Integer, _
              strFil As String, _
              strSrv As String
          strFil = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
          If strFil <> "" Then
              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) = "Sender"
                  .Cells(1, 2) = "Received"
                  .Cells(1, 3) = "Server"
              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
                      strSrv = FindString(olkMsg.Body, "Machine (.+?) is out")
                      If strSrv <> "" Then
                          strSrv = Replace(strSrv, "Machine ", "")
                          strSrv = Replace(strSrv, " is out", "")
                          '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.ReceivedTime
                          excWks.Cells(lngRow, 3) = strSrv
                          lngRow = lngRow + 1
                          lngCnt = lngCnt + 1
                      End If
                  End If
              Next
              Set olkMsg = Nothing
              excWks.Columns("A:C").AutoFit
              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
       
      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 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
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & ", "
          Next
          If Len(FindString) > 0 Then
              FindString = Left(FindString, Len(FindString) - 2)
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
      
  20. Hi David,

    I would like to thank you for your exceptional dedication and support over the last few weeks to resolve the technical issue I presented to you. You showed professional knowledge and dedicated your precious time to come up with the required resolution.

    Wish all the luck in the world!

    Regards,
    Zak Nazif

  21. Hi,

    when an email is received once a category is selected for the email i’d like to automaticaly copy the inbox fields “Received, from, subject over to an excel sheet.

    but i’d like the day and time to be omitted from the sheet when copied

    example
    email – wed 8/27/2014 8:40am – john smith – this is the subject line

    desired result
    excel – 8/27/2014 – john smith – this is the subject line

    • Hi, Brendan.

      Everything you asked for is easy except for the “automatically” part. In order to do this automatically the code would have to be able to monitor all open items and keep track of which one the change was made to (i.e. the one you just categorized). That’s not simple and it’s not something I’m prepared to take on. How about a macro that prompts you for a category and if you select one it exports the item to the spreadsheet? The difference here is that you’d run the macro to categorize the item rather than categorizing it as you normally would in Outlook. Would that work?

    • NIKIMITSY,

      Before answering you should know that I am not an Excel expert. No, there is no screenupdating command in Outlook. But, that’s immaterial. The issue is Excel not Outlook. The Excel portion of the code is simply running from inside Outlook. Outlook doesn’t control how Excel behaves. Even if there were a screenupdating command in Outlook it would only affect Outlook’s behavior, not Excel’s. If you think that adding the screenupdating = false command will solve the problem, then add that command to the macro and see what happens. the command would be

      excApp.ScreenUpdating = False

  22. how do i go abouts hiding excel from seeing the update as a have another excel program open at same time and when outlook update the excel file my excel program flashes to the excel file being updated.

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