Can I iterate through all Outlook emails in a folder including sub-folders?
Something like this ...
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
For Each oMail In oParent.Items
'Get your data here ...
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
This has a lot of great code that you are interested in. Go run it in Outlook/VBA as a macro.
Const MACRO_NAME = "OST2XLS"
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 = "Output1"
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Folder"
.Cells(1, 2) = "Sender"
.Cells(1, 3) = "Received"
.Cells(1, 4) = "Sent To"
.Cells(1, 5) = "Subject"
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) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime
excWks.Cells(lngRow, 4) = olkMsg.ReceivedByName
excWks.Cells(lngRow, 5) = olkMsg.Subject
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