Outlook VBA Importing Emails from Subfolders into Excel

Question

I am trying to import details of every email (sender, received time, subject etc.) in my Inbox into an Excel file. I have code that works fine for a specific folder within t

Answer 1

From this question Can I iterate through all Outlook emails in a folder including sub-folders?

Replace your attempt to iterate the folders ...

For Each olFolderA In olParentFolder.Folders
    For Each olMail In olFolderA.Items
    If TypeName(olMail) = "MailItem" Then
    On Error Resume Next
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = olMail.SenderEmailAddress
        aOutput(lCnt, 2) = olMail.ReceivedTime
        aOutput(lCnt, 3) = olMail.Subject
        aOutput(lCnt, 4) = olMail.Sender
        aOutput(lCnt, 5) = olMail.To
    End If
    Next
Next

...using the idea of recursion described in the currently accepted answer.

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   ' <--- no brackets around oFolder
        Next
    End If
End Sub

The fleshed out second answer shows how to declare variables outside of the code to pass values.

Option Explicit

Dim aOutput() As Variant
Dim lCnt As Long

Sub SubFolders()
'
' Code for Outlook versions 2007 and subsequent
' Declare with Folder rather than MAPIfolder
'
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet

Dim olNs As Namespace
Dim olParentFolder As Folder

Set olNs = GetNamespace("MAPI")
Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox)

lCnt = 0
ReDim aOutput(1 To 100000, 1 To 5)

ProcessFolder olParentFolder

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

Set xlSh = xlApp.Workbooks.Add.Sheets(1)

xlSh.range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True

ExitRoutine:
    Set olNs = Nothing
    Set olParentFolder = Nothing
    Set xlApp = Nothing
    Set xlSh = Nothing

End Sub

Private Sub ProcessFolder(ByVal oParent As Folder)

Dim oFolder As Folder
Dim oMail As Object

For Each oMail In oParent.Items

    If TypeName(oMail) = "MailItem" Then
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = oMail.SenderEmailAddress
        aOutput(lCnt, 2) = oMail.ReceivedTime
        aOutput(lCnt, 3) = oMail.Subject
        aOutput(lCnt, 4) = oMail.Sender
        aOutput(lCnt, 5) = oMail.To
    End If

Next

If (oParent.Folders.count > 0) Then
    For Each oFolder In oParent.Folders
        ProcessFolder oFolder
    Next
End If

End Sub