I have build to get subject from Outlook inbox. It will extract the subject from Inbox and Inbox folders. How can I extract if there are few sub folder under the folders without hard code it?
Expected result to read the subject from Inbox, FolderA, FolderB, FolderC, etc. And under FolderA probably have few subfolders on it.
Current Excel VBA code:
Option Explicit
Sub GetMailInfo()
Dim results As Variant
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
' done
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As Variant
Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As ResultItem
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer
Dim resultsList As New Collection
' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A5").Select
Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
GetFolderMails strFolderName, resultsList
' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = resultsList.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = resultsList.Item(i)
With folderItem
tempString(i + startRow, 1) = .CreationTime
tempString(i + startRow, 2) = .SenderName
tempString(i + startRow, 3) = .ReceivedByName
tempString(i + startRow, 4) = .ReceivedTime
tempString(i + startRow, 5) = .ToName
tempString(i + startRow, 6) = .Subject
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach)
Next jAttach
End If
End With
Next i
' first row of array should be header values
If headerRow Then
tempString(1, 1) = "CreationTime"
tempString(1, 2) = "SenderName"
tempString(1, 3) = "ReceivedByName"
tempString(1, 4) = "ReceivedTime"
tempString(1, 5) = "To"
tempString(1, 6) = "Subject"
End If
ExportEmails = tempString
' apply pane freeze and filtering
Range("A6").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Sub GetFolderMails(MailFolder As Object, resultsList As Collection)
Dim itm As Object
Dim newResult As ResultItem
Dim jAttach As Long
Dim subFolder As Object
For Each itm In MailFolder.Items
If IsMail(itm) Then
Set newResult = New ResultItem
With itm
newResult.CreationTime = .CreationTime
newResult.SenderName = .SenderName
newResult.ReceivedByName = .ReceivedByName
newResult.ReceivedTime = .ReceivedTime
newResult.ToName = .To
newResult.Subject = .Subject
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
newResult.Attachments.Add .Attachments.Item(jAttach).DisplayName
Next jAttach
End If
End With
resultsList.Add newResult
End If
Next itm
For Each subFolder In MailFolder.Folders
GetFolderMails subFolder, resultsList
Next subFolder
End Sub
