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.
- Start Outlook
- Press ALT+F11 to open the Visual Basic Editor
- If not already expanded, expand Microsoft Office Outlook Objects
- If not already expanded, expand Modules
- 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.
- Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
- Click the diskette icon on the toolbar to save the changes
- 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.
- With Outlook open select a folder that contains emails.
- Run the macro.
- When prompted enter a filename to save the export to. You can cancel the export by not entering anything.
- 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.
- Start Notepad.
- Copy the code from the code snippet box and paste it into Notepad.
- Edit the code as needed.
- Save the script. You can name it anything you want, just be sure that the file extension is .vbs
- 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.
- Start Outlook
- Press ALT+F11 to open the Visual Basic Editor
- If not already expanded, expand Microsoft Office Outlook Objects
- If not already expanded, expand Modules
- 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.
- Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
- Edit the code per the comments I included in it
- Click the diskette icon on the toolbar to save the changes
- Close the VB Editor
- Create a rule that fires for these messages
- 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
- Be triggered by a rule.
- Extract text from the subject line of the message that triggered the rule. The text appears between two colons.
- Connect to an already open Excel workbook.
- 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
- Select a folder in Outlook
- 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
- Ask for the path and folder name to save the data
- Ask for a date range
- 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
- Select a folder. The macro will process that folder and all sub-folders under it.
- Run the macro ExportMessagesToExcel.
- Enter the path and filename of the file the macro will export the data to. The macro will create this file.
- 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
- Adds the BCC recipients (will only show up when he runs it against a folder of sent items)
- The path to the folder the message is in
- A count of the number of recipients the message is addressed to
- The number of attachments
- 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
TechnicLee 
Hi David,
i need to run a vba program as follows:
Every day from different folders need to export messages to excel (excel will have work sheets for a month – tab wise ), received date, sent date,email address, categories and name of folder in different cells.
Is this possible.
Brgds,
Geogy Andrew
Hi, Geogy.
The answer depends on how you want this to work. Does the solution need to run by itself like a service, or is it something you’ll manually run?
David, Hello!
I need help to understand how to write VBA code to get information from outlook.
Your code works perfectly, but I’m having trouble adding new fields to excel uploads.
I will describe a situation: letters come to the General mailbox. Then these letters are taken to work employees. When taking in the work of the employee is obtained that is affixed category. I output it using ” ok Msg.Categories”
When trying to output the Recipients field using ” ok Msg.Recipients “get error 1004, but if I output” olkMsg.Recipients.Count”, then there is no error and produces a number. And so with many other fields.
I need the report to display the following fields: message ID, message Subject, Recipient, sender’s Name, Category (who took the job), date and time of receipt of the letter, date and time of affixing the category (the date and start time of the task), the date and time of response to the letter, the date and time of the Task (end date of tasks), the Duration of the task.
The next sub-task is to exclude them from uploading incoming letters if there is a certain addressee in the copy.
Hi, Ludmilla.
Based on the description, I don’t believe what you’ve described is practical to do in Outlook. Exporting messages is simple, but tying a message to a given response isn’t. Neither is tying a message to a task, especially if that task is on someone else’s task list. I’m not clear on what you mean by “exclude them from uploading incoming letters”, but I have concerns about it.
i would like to know which changes should i do on the below for version windows 64 bits.I added ptrsafe on declarations for Functions.Should i change something else?
Private Declare PtrSafe Function CloseClipboard Lib “user32” () As Long
Private Declare PtrSafe Function OpenClipboard Lib “user32” (ByVal hwnd As Long) _
As Long
Private Declare PtrSafe Function GlobalAlloc Lib “kernel32” ( _
ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib “user32” ( _
ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib “user32” () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib “user32” Alias _
“RegisterClipboardFormatA” (ByVal lpString As String) As Long
Private Declare PtrSafe Function GlobalLock Lib “kernel32” (ByVal hMem As Long) _
As Long
Private Declare PtrSafe Function GlobalUnlock Lib “kernel32” ( _
ByVal hMem As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” ( _
pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare PtrSafe Function GetClipboardData Lib “user32” ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function lstrlen Lib “kernel32” Alias “lstrlenA” ( _
ByVal lpData As Long) As Long
thank you for your help
Hi, Sarah.
That should do it.
Hello. If it posible to export all “mailto” fields that located in the body of the email messages?
Hi, Andrew.
A “mailto” is just another type of hyperlink. Rev25 exports all the hyperlinks in the body of the messages. I’ve modified the code from Rev25 to just export “mailto” links.
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, olkPrp 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 If VBA.InStr(1, VBA.LCase(objLink.href), "mailto:") > 0 Then GetLinks = GetLinks & Replace(objLink.href, "mailto:", "") & "|" End If Next GetLinks = VBA.Left(GetLinks, Len(GetLinks) - 1) Else GetLinks = "" End If Set objLink = Nothing Set colLinks = Nothing Set objDoc = Nothing Set objIE = Nothing End FunctionDavid, good day!
Could you please made code for export mails only in categorize tags.
Thanks in advance!
Hi, Aleksandr.
Do you want all messages with a category assigned or only those messages that fall into a specific set of categories?
David, Thanks a lot for your code.
I’ve got error in 3rd revision in some cases in the row:
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
if address is url encoded, how to solve it?
Thank you in advance, Andy
Hi, Andy.
What’s the error?
You’re amazing! Learned so much but now I’m stumped on trying to export a link from outlook – I’m using:
strTmp = FindString(olkMsg.Body, “HYPERLINK(.+)OGNEW500x300_EGC.png”)
strTmp = Replace(strTmp, “HYPERLINK”, “”)
strTmp = Replace(strTmp, “OGNEW500x300_EGC.png”, “”)
strTmp = Replace(strTmp, Chr(34), “”)
Bbut it is just exporting “Not Found” into the cell. I have outlook set to now download pictures and don’t want to activate it – I can manually hover over the pic and get the link but I was wondering if there were a way to get the link from the picture – here’s a screenshot of what the blocked pic looks like in outlook I’m sure you’ve seen before –
Thanks again for your help David
Hi, Trish.
Thanks!
What version of Outlook are you using?
Thanks David , I used your Rev30 code and it’s working perfectly .
may I ask for :
A loading bar/message script that shows the actual progress by folder/sub folder as the outlook
The code is getting error for any “recalled” receipt/message in the conversation view .
Hi, Paula.
I’ll give some thought to the progress bar idea.
What’s the error?
Hi David,
I spent last few hours working on different versions of the code. Revision 30 fulfills my requirements but I would really appreciate if you can help me to include the name of the subfolder in the extract.
This email and any attached files are privileged and may contain confidential information intended only for the person or persons named above. Any other distribution, reproduction, copying, disclosure, or other dissemination is strictly prohibited. If you have received this email in error, please notify the sender immediately by reply email and delete the transmission received by you. This statement applies to the initial email as well as any and all copies (replies and/or forwards) of the initial email
Hi, Hassan.
Ok. I added the folder name to the export. Replace the ExportMessagesToExcel and ProcessFolder subroutines from the code in Rev 30 with the version below. Leave the rest of the code as is.
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" .Cells(1, 4) = "Folder" 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) excWks.Cells(lngRow, 4) = olkFld.Name 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 SubHi David,
Thank you very much for your reply. I really appreciate it.
I have changed the code but I am getting the following error msg “Run time error -10409735611.
In the debug mode the error is on the line:
olkFld.DefaultItemType = olMailItem Then
Looking forward to your reply
Regards,
Hassan
Good Afternoon David,
I am using revision 3 and would like to know if it would be possible to modify the code to extract the following information:
1: Extract to include all the emails in the main and multiple subfolders for a given time range.
2: Outlook Folder Name (I need to extract data from multiple folders)
3: Receiver Details
4: Sender Details
I would really appreciate if this can be done because it will really help me with one of the projects.
Looking forward to your reply.
Hi! I’m using Rev 30 and added Body to the extract, but I need to only identify Keywords as I run into memory issues when using many subfolders.
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 ExportMessagesToExcelincludingsubfolder()
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”
.Cells(1, 4) = “Folder”
.Cells(1, 5) = “Body”
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)
excWks.Cells(lngRow, 4) = olkFld.Name
excWks.Cells(lngRow, 5) = olkMsg.Body
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
Hi, Kishan.
I’m not clear on what you’re asking for. Are you saying that you only want to export messages containing certain words? If so, do you want to look for those words in the subject, the body, or both? How many different keywords are involved? Or does “keywords” refer to categories (Microsoft sometimes refers to them as keywords)?
Almost day for premoderation?! Too long, I think….
david, one more thing. I need to make the path for Attachments with a variable for username. Something like D:\%username%\Attachments Can you,please, add it, too?
Hi, Delvin.
“Almost day for premoderation?! Too long, I think….”
I don’t typically approve a comment until I’m ready to respond. That allows me to easily separate the comments I’ve addressed from those I haven’t responded to yet. I work on these things in my spare time, so how quickly I respond depends on how much spare time I have.
Delvin,
Yes, I can add a variable to the attachment path, but it isn’t going to populate by itself. In other words, merely adding “%username%” to the path isn’t going to replace “%username%” with a username. I’ll need to know exactly where the variable portion of the path should go and what to replace it with.
Hello, David!
Thank for great work!
Can you, please, if it is possible to make columns auto adjust width and height after exporting?
And one more moment. I’m using the revision, where attachments from mail are placed in some folder. Is it possible to write the full path to such files and that cell become a link. For example, my folder for attachments is D:\Attachments, the attachments name is att.txt, so the full path as a will be “file://D:\Attachments\att.txt”
Hi, Delvin.
I can make both of the changes, but I need to know which revision you’re using.
Revision 22
Hi, Delvin.
I’ve modified the code to autofit the column width and row height. Replace the ExportMessagesToExcel subroutine with the version below. Leave the rest of the code as is.
Sub ExportMessagesToExcel() Dim olkMsg As Object, _ olkAtt As Outlook.Attachment, _ excApp As Object, _ excWkb As Object, _ excWks As Object, _ excRng 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 Set excRng = excWks.Range("A1:E" & intRow) excRng.Columns.AutoFit excRng.Rows.AutoFit Set excRng = 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 SubHi David,
Thanks for sharing such useful information.
I am struggling with extracting UserDefinedProperty from MailItem.
In my project, I have assigned a UserDefinedProperty to the MailItem when it has been sent.
Dim objProp As Outlook.UserProperty
olkMsg.Subject = sSubject
Set objProp = olkMsg.UserProperties.Add(“STAGE”, olText, True)
objProp.Value = strLocation
m_oMail.Save
I am trying move some MailItems properties to excel, i.e. Subject, Received time and UDF.
In one of your revision, I have found this line
excWks.Cells(intRow, 3) = olkMsg.UserProperties.Item(“Trans”).Value
I am trying to replicate it with
excWks.Cells(intRow, 3) = olkMsg.UserProperties.Item(“Stage”).Value
Unfortunately receive an error: Run_Time erro 91, Object variable or With block variable not set.
Also I am trying to do some checks, the folder where the MailItem is, shows that some items have userdefinedfields with text value(String).
Any advice what should I do in order to solve it? I am on Outlook 2016
Thanks in advance,
Yuriy
Solved, it fires the error, when item has empty UserDefinedField.
Is it possible to make a script based on a send item?
I need the script to write/update to an excel document when sending a amil to a specific email adress – and then i need the Body and the date sended
Hi, Simon.
Yes, that’s possible. You wouldn’t use this code though. Instead, you’d use something like this.
Sub LogMessage(Item As Outlook.MailItem) 'On the next line, edit the path to the spreadsheet. The spreadsheet must exist, this will not create it for you. Const EXCEL_FILE = "C:\Users\David\Documents\Sent-Message-Log.xlsx" Dim excApp As Object, _ excWkb As Object, _ excWks As Object, _ lngRow As Long Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Open(EXCEL_FILE) Set excWks = excWkb.Worksheets(1) lngRow = excWks.UsedRange.Rows.count + 1 excWks.Cells(lngRow, 1) = Item.SentOn excWks.Cells(lngRow, 2) = Item.Body excWkb.Close True Set excWks = Nothing Set excWkb = Nothing Set excApp = Nothing End SubOnce you’ve added the code to Outlook you’ll create a rule that fires for the messages you want to log. Set the rule’s action to “run a script”, then select this script as the one to run.
Hi David,
The below vbs was generously developed by yourself for me, in 2013. I am currently trying to run it on Outlook 2010 under windows 10, however, it does not extract ALL the messages in ALL subfolders. It just extracts one folder under Inbox and then stops, although there are other subfolders.
I appreciate if you can assist me to overcome this issue.
‘–> 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 = “D:\OutlookExportMail\”
Const MACRO_NAME = “Export Messages to Excel (Rev Zak)”
Const olExchangeUserAddressEntry = 0
Const olMailItem = 0
Const olRequired = 1
Const olMSG = 3
Const olOLE = 6
Const olMail = 43
Const olReport = 46
Const olMeetingRequest = 53
Const olMeetingCancellation = 54
Dim olkApp, olkSes, excApp, excWkb, excWks, objFSO, intVer, lngRow, strTyp, strFil
‘–> Connect to Outlook
Set olkApp = CreateObject(“Outlook.Application”)
Set olkSes = olkApp.GetNamespace(“MAPI”)
olkSes.Logon olkApp.DefaultProfileName
‘–> Initialize some variables
Set objFSO = CreateObject(“Scripting.FileSystemObject”)
intVer = GetOutlookVersion()
‘–> Connect to Excel
strFil = InputBox(“Enter the name of the Excel file the export is to be written to.”, MACRO_NAME)
If strFil “” Then
Set excApp = CreateObject(“Excel.Application”)
If objFSO.FileExists(strFil) Then
If MsgBox(“The file ” & strFil & ” already exists. Are you sure you want to append to it?”, vbQuestion + vbYesNo, MACRO_NAME) = vbYes Then
strTyp = “Append”
Set excWkb = excApp.Workbooks.Open(strFil)
Else
strTyp = “CreateNewName”
Set excWkb = excApp.Workbooks.Add
End If
Else
strTyp = “Create”
Set excWkb = excApp.Workbooks.Add
End If
Set excWks = excWkb.Worksheets(1)
Select Case strTyp
Case “Create”, “CreateNewName”
With excWks
.Cells(1, 1) = “Subject”
.Cells(1, 2) = “Body”
.Cells(1, 3) = “Sender”
.Cells(1, 4) = “To”
.Cells(1, 5) = “CC”
.Cells(1, 6) = “Date of Message”
.Cells(1, 7) = “Folder”
.Cells(1, 8) = “Attachments”
End With
End Select
lngRow = excWks.UsedRange.rows.Count + 1
excApp.Visible = True
‘–> Main routine
ExportMessagesToExcel olkSes.PickFolder
excWks.Columns(“A:ZZ”).WrapText = False
‘–> Save and close the workbook
Select Case strTyp
Case “Append”
excWkb.Save
Case “Create”
excWkb.SaveAs strFil
Case “CreateNewName”
strFil = InputBox(“You opted not to overwrite the file ” & strFil & vbCrLf & “Please enter a path to write the export to.”, MACRO_NAME)
excWkb.SaveAs strFil
End Select
excWkb.Close True
‘–> Notify the user that the process is finished
MsgBox “Export complete.”, vbInformation + vbOKOnly, MACRO_NAME
Else
MsgBox “You did not enter a filename to export to. Operation cancelled.”, vbInformation + vbOKOnly, MACRO_NAME
End If
‘–> Disconnect from Outlook
olkSes.Logoff
‘–> Destroy all objects
Set objFSO = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
‘–> Terminate the script
WScript.Quit
Sub ExportMessagesToExcel(olkFld)
‘–> Declare some variables
Dim olkMsg, olkRcp, olkSub, olkAtt, lngCol, strAFN, arrTmp, strPth, intPtr, strTo, strAdr
‘–> Main routine
‘Only process folders containing emails, not contacts, calendars, tasks, or notes.
If olkFld.DefaultItemType = olMailItem Then
‘Make sure the folder path exists in Windows
strPth = Replace(olkFld.FolderPath, “\\”, “”)
arrTmp = Split(strPth, “\”)
strPth = EXPORT_FOLDER
For intPtr = LBound(arrTmp) To UBound(arrTmp)
strPth = strPth & arrTmp(intPtr)
If Not objFSO.FolderExists(strPth) Then
objFSO.CreateFolder strPth
End If
strPth = strPth & “\”
Next
‘Process the items in the folder
For Each olkMsg In olkFld.Items
Select Case olkMsg.Class
Case olMail, olReport, olMeetingRequest, olMeetingCancellation
WScript.Echo Now & vbTab & olkMsg.Subject
lngCol = 8
strAdr = “”
‘Add a row for each field in the message you want to export
With excWks
strTmp = olkMsg.Subject
If Len(strTmp) >= 100 Then
strTmp = Left(strTmp, 100)
End If
.Cells(lngRow, 1) = strTmp
.Cells(lngRow, 2) = olkMsg.Body
Select Case olkMsg.Class
Case olMail
strAdr = GetSMTPAddress(olkMsg, intVer)
If Left(strAdr, 1) = “/” Then
.Cells(lngRow, 3) = olkMsg.SenderName
Else
.Cells(lngRow, 3) = strAdr
End If
.Cells(lngRow, 4) = olkMsg.To
.Cells(lngRow, 5) = olkMsg.CC
.Cells(lngRow, 6) = IIF(.Cells(lngRow, 3).Value = olkSes.CurrentUser.Address, olkMsg.SentOn, olkMsg.ReceivedTime)
Case olReport
If LCase(olkMsg.MessageClass) = “report.ipm.note.ndr” Then
.Cells(lngRow, 3) = FindString(olkMsg.Body, “\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b”)
Else
strAdr = MeetingSenderSMTP(olkMsg)
If Left(strAdr, 1) = “” Then
.Cells(lngRow, 3) = “Unknown”
Else
.Cells(lngRow, 3) = strAdr
End If
End If
.Cells(lngRow, 6) = olkMsg.CreationTime
Case olMeetingRequest, olMeetingCancellation
strAdr = MeetingSenderSMTP(olkMsg)
If Left(strAdr, 1) = “/” Then
.Cells(lngRow, 3) = olkMsg.SenderName
Else
.Cells(lngRow, 3) = strAdr
End If
strTo = “”
For Each olkRcp In olkMsg.Recipients
If olkRcp.Type = olRequired Then
strTo = strTo & olkRcp.Name & “; ”
End If
Next
If strTo “” Then
strTo = Left(strTo, Len(strTo) – 2)
End If
.Cells(lngRow, 4) = strTo
.Cells(lngRow, 6) = IIF(.Cells(lngRow, 3).Value = olkSes.CurrentUser.Address, olkMsg.SentOn, olkMsg.ReceivedTime)
End Select
.Cells(lngRow, 7) = olkFld.FolderPath
End With
strTmp = strPth & RemoveIllegalCharacters(strTmp) & ” ” & Format(excWks.Cells(lngRow, 6).Value) & “.msg”
strTmp = Replace(strTmp, “‘”, “””)
olkMsg.SaveAs strTmp, olMSG
excWks.Hyperlinks.Add excWks.Range(“A” & lngRow), “FILE:\\” & strTmp, , , olkMsg.Subject
For Each olkAtt In olkMsg.Attachments
If (Not IsHiddenAttachment(olkAtt)) And (Not olkAtt.Type = olOLE) Then
strAFN = strPth & objFSO.GetBaseName(olkAtt.Filename) & Format(excWks.Cells(lngRow, 6).Value) & “.” & objFSO.GetExtensionName(olkAtt.Filename)
olkAtt.SaveAsFile strAFN
excWks.Hyperlinks.Add excWks.Range(NumberToLetter(lngCol) & lngRow), “FILE:\\” & strAFN, , , olkAtt.Filename
lngCol = lngCol + 1
End If
Next
lngRow = lngRow + 1
End Select
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 olkRcp = Nothing
Set olkSub = Nothing
Set olkAtt = Nothing
End Sub
Function GetSMTPAddress(Item, intOutlookVersion)
Dim olkSnd, olkEnt
On Error Resume Next
Select Case True
Case (intOutlookVersion >= 1) And (intOutlookVersion <= 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
WScript.Echo "SMTP2007"
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E"😉
On Error GoTo 0
Set olkPA = Nothing
End Function
Function MeetingSenderSMTP(olkMsg)
Dim olkPA
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
MeetingSenderSMTP = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E"😉
On Error GoTo 0
Set olkPA = Nothing
End Function
Function IsHiddenAttachment(olkAtt)
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Dim olkPA, varTemp
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
Function NumberToLetter(intNumber)
NumberToLetter = Chr(64 + intNumber)
End Function
Function RemoveIllegalCharacters(strValue)
‘ Purpose: Remove characters that cannot be in a filename from a string.’
‘ Written: 4/24/2009’
‘ Author: BlueDevilFan’
‘ Outlook: All versions’
RemoveIllegalCharacters = strValue
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “:”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), “‘”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “/”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “\”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “|”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “?”, “”)
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, “*”, “”)
End Function
Function IIF(varTest, varTrue, varFalse)
If varTest Then
IIF = varTrue
Else
IIF = varFalse
End If
End Function
Function Format(datVal)
Format = Year(datVal) & “-” & StrZero(Month(datVal), 2) & “-” & StrZero(Day(datVal), 2) & “-” & StrZero(Hour(datVal), 2) & “-” & StrZero(Minute(datVal), 2) & “-” & StrZero(Second(datVal), 2) & “-” & Replace(Timer, “.”, “-“)
End Function
Function StrZero(varNumber, intLength)
Dim intItemLength
If IsNumeric(varNumber) Then
intItemLength = Len(CStr(Int(varNumber)))
If intItemLength 0 Then
FindString = Left(FindString, Len(FindString) – 2)
End If
Set objRegEx = Nothing
Set colMatches = Nothing
Set objMatch = Nothing
End Function
Hi, Zak.
I looked over the code and don’t see any reason why it should fail to get all the sub-folders under the selected folder. We need to figure out what’s going on. To do that, please replace this block of code at the bottom of the ExportMessagesToExcel sub
with this
For Each olkSub In olkFld.Folders WScript.Echo "Now processing: " & olkSub.FolderPath ExportMessagesToExcel olkSub NextWith that change in place the code will display a pop-up showing the name of each sub-folder it processes. Let me know what happens.
Hi David, Apologies for the late reply as I did not receive, from the system, the e-mail notification of your reply!
I applied your change, however, it does not display the “Now processing:” message!
More detail of the error: When I previously ran the VBS on the “Sent” folder it will return all subfolders messages, as requested. However, if I run it on the “Inbox” it will only return the messages in the Inbox and stops without returning the contents of the subfolders!
I appreciate you assistance.
Hi David,
Another update after further observations and analysis. I just found that inside the Inbox there are two consecutive e-mails that do not display any information (subject, From address)! After isolating those two e-mails the VBS ran with no issues, as designed.
However, the “Now processing:” message does not display when running on the Inbox (even after removing the corrupted e-mails), although, it does display when running on any other folder!
So, now the VBS is producing the expected outputs.
Hi, Zak.
Ok. Thanks for letting me know.
Hi, I am using revision 3 but would like to know if there is a possibility to add the outlook folder name beside the email details. I want the extract to appear as follows
1: Outlook Folder Name (I need to extract data from multiple folders)
2: Subject
3: Received Date
4: Sender Details
Thanks,
Hassan
Hi, Hassan.
Replace the ProcessFolder subroutine from the post with the one below.
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) = olkFld.Name excWks.Cells(intRow, 2) = olkMsg.Subject excWks.Cells(intRow, 3) = olkMsg.ReceivedTime excWks.Cells(intRow, 4) = 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 SubHello David, I am using the code below to export my outlook messages to excel but after I updated my PC to windows 10 and office 16. The messages in Excel are exporting incorrectly. Could you please help me?
‘ Desenvolvido por Vagston Bueno – Branch Controller CWB
‘ Desenvolvido em 04/04/2014.
‘Backup de Email p/ excel por pasta
‘–> Declare some constants
‘On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = “C:\OutlookEmails\NewBackupReport.xlsm”
‘On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = “Sheet1”
‘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:\OutlookEmails\NewBackup092017”
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 ByFolderRunExportMessagesToExcel()
‘–> Declare some variables
‘ Desenvolvido por Vagston Bueno – Branch Controller CWB
‘ Desenvolvido em 04/04/2014.
‘Backup de Email p/ excel por pasta
Dim strWkb As String
If MsgBox(“Deseja efetuar backup da pasta selecionada? Lembre-se de fechar o arquivo excel de backup antes de clicar em OK!”, vbInformation + vbOKCancel, MACRO_NAME) = vbCancel Then
Cancel = True
Else
strWkb = WORKBOOK_PATH
If strWkb “” Then
Set objFSO = CreateObject(“Scripting.FileSystemObject”)
Set excApp = CreateObject(“Excel.Application”)
If objFSO.FileExists(strWkb) Then
Set excWkb = excApp.Workbooks.Open(strWkb)
Set excWks = excWkb.Worksheets(SHEET_NAME)
lngRow = excWks.UsedRange.Rows.Count + 1
Else
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.Worksheets(1)
lngRow = 2
‘Write Excel Column Headers
With excWks
.Cells(1, 1) = “Date”
.Cells(1, 2) = “Time”
.Cells(1, 3) = “Subject”
.Cells(1, 4) = “To”
.Cells(1, 5) = “From”
.Cells(1, 6) = “Attachments”
.Cells(1, 7) = “ID”
.Cells(1, 8) = “Link”
.Cells(1, 9) = “CC”
.Cells(1, 10) = “Body”
.Cells(1, 11) = “Folder”
End With
bolNew = True
End If
ExportMessagesToExcel Application.ActiveExplorer.CurrentFolder
excWks.Columns(“A:B”).AutoFit
excWks.Columns(“J:J”).WrapText = False
excWkb.SaveAs strWkb
excWkb.Close
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
Set objFSO = Nothing
MsgBox “Process complete. A total of ” & lngCnt & ” messages were exported.”, vbInformation + vbOKOnly, MACRO_NAME
Else
MsgBox “Operation canceled.”, vbInformation + vbOKOnly, MACRO_NAME
End If
End If
Exit Sub
End Sub
Private Sub ExportMessagesToExcel(olkFol As Outlook.MAPIFolder)
‘–> 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.msg”, olMSG
‘Save the attachments to the folder
For Each olkAtt In olkMsg.Attachments
If Not IsHiddenAttachment(olkAtt) Then
On Error Resume Next
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.ReceivedTime
excWks.Cells(lngRow, 2) = Format(olkMsg.ReceivedTime, “hh:nn”)
excWks.Cells(lngRow, 3) = olkMsg.Subject
excWks.Cells(lngRow, 4) = olkMsg.To
excWks.Cells(lngRow, 5) = olkMsg.SenderName
excWks.Cells(lngRow, 6) = strAtt
excWks.Cells(lngRow, 7) = olkMsg.EntryID
excWks.Cells(lngRow, 9) = olkMsg.CC
excWks.Cells(lngRow, 10) = olkMsg.Body
excWks.Cells(lngRow, 11) = olkMsg.Parent.FolderPath
‘Lidar com erro no Hyperlink do excel
On Error Resume Next
‘termina aqui
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
Thank you
Vagston Bueno
Hi, Vagston.
What does “incorrectly” mean in this context? I need to know what’s happening in order to suggest a solution.
Hello, David!
I have problem with exporting more than 1000 messages http://joxi.ru/BA01G5WfJzOL1r
http://joxi.ru/nAybJvMfY5Jpbr
Macros exports 871 messages without any problems
Outlook 2010
How can i fix it?
Hi, Stas.
Which version are you using?
Hello, David!
I have Outlook 2010 home&business 64 bit v14.0.6023.1000
http://joxi.ru/a2XKnzGh1dbqom
OS Windows 8.1 Pro
Hi, Stas.
Which version of my code are you using? There’s the original version and 49 revisions. I need to know which of those you’re using in order to troubleshoot the problem.
Hi David,
I’ve used and combined your macros for many years now. Big fan. I recently encountered a problem using GetSMTPAddress(olkMsg, intVersion). In some cases I do not get the email address but instead the following:
Received Email
6/15/2017 John.Doe@outlook.com
6/20/2017 /O=MMS/OU=EXTERNAL (FYDIBOHF25SPDLT)/CN=RECIPIENTS/CN=466E409F3B9F4ABCA1756BFBF806E948
Do you have any idea how to solve this?
Thanks,
Luis
Const MACRO_NAME = “Export Messages to Excel (Version Sape_I)”
Const WORKBOOK_PATH = “etc etc”
Const SHEET_NAME = “New_data”
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 = WORKBOOK_PATH
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.Open(WORKBOOK_PATH)
Set excWks = excWkb.Worksheets(SHEET_NAME)
lngRow = excWks.UsedRange.Rows.Count + 1
‘Write Excel Column Headers
With excWks
.Cells(1, 1) = “Received”
.Cells(1, 2) = “Email”
.Cells(1, 3) = “Subject”
.Cells(1, 4) = “Categories”
End With
ProcessFolder Application.ActiveExplorer.CurrentFolder
excWkb.SaveAs strFilename
excWkb.Close
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, "dddddh:nnAMPM ") & " '")
'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.ReceivedTime
excWks.Cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(lngRow, 3) = olkMsg.Subject
excWks.Cells(lngRow, 4) = olkMsg.Categories
lngRow = lngRow + 1
lngMessages = lngCnt + 1
End If
Next
Set olkMsg = Nothing
End If
For Each olkSub In olkFld.Folders
ProcessFolder olkSub
Next
Set olkSub = Nothing
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is 0 Then
GetMsgBody = Left(strTxt, lngPos – 1)
Else
GetMsgBody = strTxt
End If
End Function
Hi, Luis.
What version of Outlook are you using?
David, i used 2 revisions, both had same problems.
One of them:
MACRO_NAME = “Export Messages to Excel (Rev 42)”
David hi,
First, the article is very useful.
i need your help.
there is function like “Function GetSMTPAddress” fro the “TO” object?
the Function GetSMTPAddress in your revision relative to the sender email address ,and i need the SMPT FOR THE “TO” email address object.
Thanks for your help
Hi, papompapom.
What you think of as the “TO” object is really the “Recipients” collection. It contains a Recipient object for each addressee. Do you want the SMTP address for every object in the collection or just individual objects (i.e. specific addressees)? If you want them all, then how do you want them returned (e.g. a delimited list, an array)?
david hi,
in Revision 5 there is 5 object :
.Cells(1, 1) = “Subject”
.Cells(1, 2) = “Received”
.Cells(1, 3) = “Sender”
.Cells(1, 4) = “To”
.Cells(1, 5) = “Attachments”
for the “Sender” there is function that convert from the “nickname” of the person to the Email address – “GetSMTPAddress”
I would like to have the same function “GetSMTPAddress” for the “TO” object (there is only one address, so I don’t need array for that)
Thanks
Hi, Dror.
Those are not objects. Those are literal values being inserted into specific rows/columns of the spreadsheet. Outlook does not have a “TO” object. As I explained in my previous response, what you see in the “TO” line is actually the “Recipients” collection. The “Recipients” collection is composed of one or more “Recipient” objects. Each “Recipient” object represents one addressee. If you only want the SMTP address of the first “Recipient” object, then that’s fine so long as the messages in question only have one addressee or you only want the SMTP of the first addressee in the collection. Here’s a function that returns the SMTP address of a “Recipeint” object.
Function GetSMTP(olkRec As Outlook.recipient) As String Dim olkPA As Outlook.PropertyAccessor On Error Resume Next Set olkPA = olkRec.PropertyAccessor GetSMTP = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") On Error GoTo 0 Set olkPA = Nothing End FunctionHere’s how to use this
This will return the SMTP address of the first “Recipient” object in the “Recipients” collection.
Works perfect.
Thank you so much.
You’re welcome!
Hi David,
Thank you very much for the article, Very helpful.
anyway, there is function like “GetSMTPAddress” for the “TO” object?
for example the function will convert from the nmae of the person that i send him mail to the SMTP addrress – from “dror” to dror@gmail.com/
Thanks for your help
Irrelevant
HI David,
Thank you so much, the article you posted is very useful.
Anyway, there is a function that convert the “TO” from the name of the person to is email address (For example: from “Michael” to Michael@gmail.com)
like GetSMTPAddress but for the “TO” object?
thanks again for your help
Irrelevant
Hi David,
Using the macro revision 31, is there a way to read only the email that have in the subject line the words Tasks progress and then execute the export to Excel only for the new received email.
Regards,
Chuck
Hi, Chuck.
Yes, it simple to only process those message that have any given work or phrase in the subject. All you need to do is add an IF … THEN statement immediately after line 31 of the ExportMessagesToExcel subroutine. Something like this
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 If InStr(1, olkMsg.Subject, "Tasks progress") > 0 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 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 SubI’m not clear on what you mean in your second question about “new received email”. Does “new” mean you want to process messages as they arrive or does “new” mean unread messages? Or does “new” mean something else?