Looping through every subfolder in inbox using vba - vba

Question

I have a problem looping through every sub-folder of an Outlook email using following code:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
'Set objFolder = ActiveExplorer.CurrentFolder
Set objFolder = Session.GetFolderFromID (Application.ActiveExplorer.CurrentFolder.EntryID)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
' MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oStartDate As String
Dim oEndDate As String
Set dict = CreateObject("Scripting.Dictionary")
oStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
oEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oStartDate & "' And [Received] <= '" & oEndDate & "'")
myItems.SetColumns ("Categories")
' date for mssg:
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output for days
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
The code runs on the inbox itself, but it doesn't dig into sub-folders.
I have been trying to loop it correctly but I keep failing.
Thanks for help!

Answer 1

The code in ProcessFolder will call itself for each subfolder within the parent folder.
Option Explicit
Private MessageText As String
Public Sub ListAllFolders()
'Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
'''''''''''''''''''''''''''''''''''''''''
'No need to reference the Outlook application as the code
'is running from within the application itself.
''''''''''''''''''''''''''''''''''''''''
'Set oOutlook = GetObject(, "Outlook.Application")
'Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set nNameSpace = GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
ProcessFolder mFolderSelected
MsgBox MessageText
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
'Get the folder name and count of items.
MessageText = MessageText & oParent.Name & ": " & oParent.Items.Count & vbCr
'If there are subfolders then process them as well.
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
End Sub
Edit:
This is the code I use to count the different categories of emails in the selected folder & subfolders.
It splits the count by date and category:
Public Sub CreateReport()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim oItem As Object
Dim rLastCell As Range
Dim x As Long
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
''''''''''''''''''''''''''''''''
'Clear Sheet of existing data. '
''''''''''''''''''''''''''''''''
shtAnalysis.Cells.Delete Shift:=xlUp
ProcessFolder mFolderSelected
''''''''''''''''''''''''''
'Tidy up and add totals. '
''''''''''''''''''''''''''
Set rLastCell = LastCell(shtAnalysis)
ThisWorkbook.Activate
MsgBox "Complete", vbOKOnly
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
Dim PropertyAccessor As Object
Dim v As Variant
On Error Resume Next
For Each oMail In oParent.Items
PlaceDetails oMail
Next oMail
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
On Error GoTo 0
End Sub
Sub PlaceDetails(oMailItem As Object)
Dim rFoundCell As Range
Dim lColumn As Long
Dim lRow As Long
'''''''''''''''''''''''''''''''''''''''''''''
'Only process emails containing a category. '
'''''''''''''''''''''''''''''''''''''''''''''
If oMailItem.categories <> "" Then
With shtAnalysis
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Does the category already exist on the spreadsheet? '
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Rows("1:1").Cells.Find(What:=oMailItem.categories, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lColumn = rFoundCell.Column
Else
lColumn = LastCell(shtAnalysis).Column + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Next find the row by looking for sent on date in column A. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Columns("A:A").Cells.Find(What:=Int(oMailItem.senton), After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lRow = rFoundCell.Row
Else
lRow = LastCell(shtAnalysis).Row + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''
'Place category, date and count on the sheet. '
'''''''''''''''''''''''''''''''''''''''''''''''
.Cells(lRow, 1).Value = Int(oMailItem.senton)
.Cells(1, lColumn).Value = oMailItem.categories
If .Cells(lRow, lColumn) = "" Then
.Cells(lRow, lColumn).NumberFormat = "General"
.Cells(lRow, lColumn) = 1
Else
.Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
End If
End With
End If
End Sub
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function