The following code exports emails to Excel from Outlook.
The code is late bound, so first we need to place the following enumeration into a standard module when calling code meant for Outlook.
Public Enum OlDefaultFolders olFolderCalendar = 9 olFolderConflicts = 19 olFolderContacts = 10 olFolderDeletedItems = 3 olFolderDrafts = 16 olFolderInbox = 6 olFolderJournal = 11 olFolderJunk = 23 olFolderLocalFailures = 21 olFolderNotes = 12 olFolderOutbox = 4 olFolderSentMail = 5 olFolderServerFailures = 22 olFolderSyncIssues = 20 olFolderTasks = 13 olPublicFoldersAllPublicFolders = 18 End Enum
This code should be placed at the top of a standard module. If you have downloaded the module from List of Enumerated Constants for Late Bound VBA Automation then you should already have this enumeration.
See Where do I paste the code that I want to use in my workbook for placement assistance.
Export Emails
This code will return emails in the local default Inbox folder and write them to an array. You can then put them into a listbox, or dump them onto a worksheet. You can also configure the code to use a different mail folder, perhaps from a public folder or subfolder.
An optional header row is also provided, so you can see what each column of values represents. I chose to grab every possible property of the MailItem Object where possible.
Function ExportEmails(Optional headerRow As Boolean = False) As String()
Dim olApp As Object ' Outlook.Application
Dim olNS As Object ' Outlook.Namespace
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set mailFolderItems = GetItems(olNS, olFolderInbox)
' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = mailFolderItems.count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 38)
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.item(i)
If IsMail(folderItem) Then
Set msg = folderItem
End If
With msg
tempString(i + startRow, 1) = .BCC
tempString(i + startRow, 2) = .BillingInformation
tempString(i + startRow, 3) = Left$(.Body, 900) ' throws error without limit?
tempString(i + startRow, 4) = .BodyFormat
tempString(i + startRow, 5) = .Categories
tempString(i + startRow, 6) = .CC
tempString(i + startRow, 7) = .Companies
tempString(i + startRow, 8 ) = .CreationTime
tempString(i + startRow, 9) = .DeferredDeliveryTime
tempString(i + startRow, 10) = .DeleteAfterSubmit
tempString(i + startRow, 11) = .ExpiryTime
tempString(i + startRow, 12) = .FlagDueBy
tempString(i + startRow, 13) = .FlagIcon
tempString(i + startRow, 14) = .FlagRequest
tempString(i + startRow, 15) = .FlagStatus
tempString(i + startRow, 16) = .Importance
tempString(i + startRow, 17) = .LastModificationTime
tempString(i + startRow, 18) = .Mileage
tempString(i + startRow, 19) = .OriginatorDeliveryReportRequested
tempString(i + startRow, 20) = .Permission
tempString(i + startRow, 21) = .ReadReceiptRequested
tempString(i + startRow, 22) = .ReceivedByName
tempString(i + startRow, 23) = .ReceivedOnBehalfOfName
tempString(i + startRow, 24) = .ReceivedTime
tempString(i + startRow, 25) = .RecipientReassignmentProhibited
tempString(i + startRow, 26) = .ReminderSet
tempString(i + startRow, 27) = .ReminderTime
tempString(i + startRow, 28) = .ReplyRecipientNames
tempString(i + startRow, 29) = .SenderEmailAddress
tempString(i + startRow, 30) = .SenderEmailType
tempString(i + startRow, 31) = .SenderName
tempString(i + startRow, 32) = .Sensitivity
tempString(i + startRow, 33) = .SentOn
tempString(i + startRow, 34) = .Size
tempString(i + startRow, 35) = .Subject
tempString(i + startRow, 36) = .To
tempString(i + startRow, 37) = .VotingOptions
tempString(i + startRow, 38) = .VotingResponse
End With
Next i
' first row of array should be header values
If headerRow Then
tempString(1, 1) = "BCC"
tempString(1, 2) = "BillingInformation"
tempString(1, 3) = "Body"
tempString(1, 4) = "BodyFormat"
tempString(1, 5) = "Categories"
tempString(1, 6) = "CC"
tempString(1, 7) = "Companies"
tempString(1, 8 ) = "CreationTime"
tempString(1, 9) = "DeferredDeliveryTime"
tempString(1, 10) = "DeleteAfterSubmit"
tempString(1, 11) = "ExpiryTime"
tempString(1, 12) = "FlagDueBy"
tempString(1, 13) = "FlagIcon"
tempString(1, 14) = "FlagRequest"
tempString(1, 15) = "FlagStatus"
tempString(1, 16) = "Importance"
tempString(1, 17) = "LastModificationTime"
tempString(1, 18) = "Mileage"
tempString(1, 19) = "OriginatorDeliveryReportRequested"
tempString(1, 20) = "Permission"
tempString(1, 21) = "ReadReceiptRequested"
tempString(1, 22) = "ReceivedByName"
tempString(1, 23) = "ReceivedOnBehalfOfName"
tempString(1, 24) = "ReceivedTime"
tempString(1, 25) = "RecipientReassignmentProhibited"
tempString(1, 26) = "ReminderSet"
tempString(1, 27) = "ReminderTime"
tempString(1, 28) = "ReplyRecipientNames"
tempString(1, 29) = "SenderEmailAddress"
tempString(1, 30) = "SenderEmailType"
tempString(1, 31) = "SenderName"
tempString(1, 32) = "Sensitivity"
tempString(1, 33) = "SentOn"
tempString(1, 34) = "Size"
tempString(1, 35) = "Subject"
tempString(1, 36) = "To"
tempString(1, 37) = "VotingOptions"
tempString(1, 38) = "VotingResponse"
End If
ExportEmails = tempString
End FunctionHelper Functions
The following should also be placed in a standard module, as these are the helper functions used by the main function:
Visit Utility Functions for IsMail, GetNS, GetOutlookApp, GetItems.
Sample Usage
This sample procedure gets the emails from the default Inbox folder and pastes them into Excel, along with header row:
Sub GetMailInfo() Dim results() As String ' get contacts results = ExportEmails(True) ' paste onto worksheet Range(cells(1, 1), cells(UBound(results), UBound(results, 2))).value = results End Sub
The sample workbook includes the code and a userform so you can see how the results would be put into a listbox.
