VBA code to loop through every folder and subfolder in Outlook

Question

I am trying to get the following code to look through all folders and subfolders in Outlook under Inbox and source data from the e-mails.

The code runs but it ONLY looks through e-mails in the Inbox and the FIRST subfolder level of the Inbox. However, it doesn't look through all the subsequent subfolder levels within the first subfolder.

So here's what it looks through

Inbox --> Subfolder 1 --> stops looking

I want it to look through

Inbox --> Subfolder 1 --> Subfolder 2 --> Subfolder "n"

So for example, I have the following folders in my Inbox:

1. Inbox --> Canada --> Ontario --> Toronto

OR

2. Inbox --> Clothes --> Cheap clothes --> Walmart

It only looks through Inbox and the first level, so Canada or clothes, but doesn't look into the folders under Canada/clothes, such as Ontario or Cheap Clothes. I want it to go further and look at Toronto and Walmart, which are folders under Ontario and Cheap clothes.

Answer 1

There is an extra loop and you are mixing up parent and folder. This is working Excel code, ignoring your workbook and worksheets.

Option Explicit

Sub repopulate3()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olparentfolder As Outlook.Folder
Dim olMail As Object

Dim eFolder As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet

Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    Set olApp = CreateObject("Outlook.Application")
End If

Set olNs = olApp.GetNamespace("MAPI")
Set olparentfolder = olNs.GetDefaultFolder(olFolderInbox)

'wb.Sheets("vlookup").range("A2:C500").ClearContents

'i think you want column E here, not L?
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

ProcessFolder olparentfolder

ExitRoutine:

Set olparentfolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)

Dim olFolder As Outlook.Folder
Dim olMail As Object

Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

For i = oParent.Items.Count To 1 Step -1

    Debug.Print oParent
    If TypeOf oParent.Items(i) Is MailItem Then
        Set olMail = oParent.Items(i)

        Debug.Print " " & olMail.Subject
        Debug.Print " " & olMail.ReceivedTime
        Debug.Print " " & olMail.SenderEmailAddress
        Debug.Print

        'For iCounter = 2 To lastrow
            'If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
                'With ws
                '   lrow = .range("A" & .Rows.count).End(xlUp).Row
                '   .range("C" & lrow + 1).Value = olMail.body
                '   .range("B" & lrow + 1).Value = olMail.ReceivedTime
                '   .range("A" & lrow + 1).Value = olMail.SenderEmailAddress
                'End With
            'End If
        'Next iCounter

    End If

Next i

If (oParent.Folders.Count > 0) Then
    For Each olFolder In oParent.Folders
        ProcessFolder olFolder
    Next
End If

End Sub