Outlook VBA to list the text strings of all folders and subfolders i.e., beyond two levels

[dougmarkham]

Hi Folks,

The code below is listing the Outlook path for all my Outlook Folders but only two levels deep.
e.g., \\Douglas.Markham@thecompany.com\Inbox\01) doug's jobs\completed jobs

I've tried to nest a third For loop into the code to pull out the next level of folder e.g.,
\\Douglas.Markham@thecompany.com\Inbox\01) doug's jobs\completed jobs\1) Set-up meeting in meeting room 1

When I run the code, I get the following error:

Sub Level3()

    'Needs reference to MS Outlook Object Library
    
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olParentFolder As Outlook.MAPIFolder
    Dim olFolderA As Outlook.MAPIFolder
    Dim olFolderB As Outlook.MAPIFolder
    Dim olFolderC As Outlook.MAPIFolder
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")

    Set olParentFolder = olNs.Folders("Douglas.Markham@thecompany.com").Folders("Inbox")

    For Each olFolderA In olParentFolder.Folders
        Debug.Print olFolderA.FolderPath ', olFolderA.Items.Count ', olFolderA.Folders.Count
        
        For Each olFolderB In olFolderA.Folders
            Debug.Print olFolderB.FolderPath ', olFolderB.Items.Count
        Next
            'My addition to the code (first line below) that causes run-time error 91
            For Each olFolderC In olFolderB.Folders
                Debug.Print olFolderC.FolderPath, olFolderC.Items.Count
            Next
    Next
    
End Sub

I have two issues I'm trying to solve:

1) I have up to 5 levels of nesting in my Outlook folders: would anyone please be willing to help me modify the code so I can pull out all the sub-folders?
2) This above code prints the folder paths into the Immediate window in VB Editor. Would anyone be willing to help me export the results to a specific excel file instead?

Kind regards,

Doug.

 

[Legacy 456155]

Using recursion, you can simplify your code a bit. This will also continue to work if you add more levels.

Sub Level3()

    'Needs reference to MS Outlook Object Library
   
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olParentFolder As Outlook.MAPIFolder
    Dim olFolderA As Outlook.MAPIFolder
    Dim olFolderB As Outlook.MAPIFolder
    Dim olFolderC As Outlook.MAPIFolder
   
    Set olApp = Application 'New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")

    Set olParentFolder = olNs.Folders("Douglas.Markham@thecompany.com").Folders("Inbox")
    DrillDown olParentFolder
    Debug.Print olParentFolder.FolderPath, olParentFolder.Items.Count
End Sub

Private Function DrillDown(parentFolder As Outlook.MAPIFolder)
    Dim f As Outlook.MAPIFolder
    For Each f In parentFolder.Folders
        DrillDown f
        Debug.Print f.FolderPath, f.Items.Count
    Next
End Function

 

[kennypete]

The slimmed down and modified version of How to export and print list of all folders and subfolders in Outlook? below will create "tree" .csv of the selected Outlook folder, noting, of course, it is Outlook VBA, not Excel, but if you want just a .csv tree output why start within Excel at all?

I don't use subfolders, but after adding some and testing it (in Outlook Office 365 pro plus) works well - the output .csv opened in Excel below:

Dim gFileName, gBase

Public Sub ExportFolderTree()
Dim objOutlook
Dim F, Folders
Dim Result
Set objOutlook = CreateObject("Outlook.Application")
Set F = objOutlook.Session.PickFolder
If Not F Is Nothing Then
    Set Folders = F.Folders
    gFileName = GetDesktopFolder() & "\Outlook-Folders.csv"
    gBase = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
    WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
    LoopFolders Folders
    Set F = Nothing
    Set Folders = Nothing
    Set objOutlook = Nothing
End If
End Sub
 
Private Function GetDesktopFolder()
Dim objShell
Set objShell = CreateObject("WScript.Shell")
GetDesktopFolder = objShell.SpecialFolders("Desktop")
Set objShell = Nothing
End Function
 
Private Sub LoopFolders(Folders)
Dim F
For Each F In Folders
    WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
    LoopFolders F.Folders
Next
End Sub
 
Private Sub WriteToATextFile(OLKfoldername)
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(gFileName, 8, True)
objTextFile.WriteLine (OLKfoldername)
objTextFile.Close
Set objFSO = Nothing
Set objTextFile = Nothing

End Sub
 
Private Function CreateFolderTree(OLKfolderpath, OLKfoldername)
Dim i, x, OLKprefix
i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
For x = gBase To i
    OLKprefix = OLKprefix & "-,"
Next
CreateFolderTree = OLKprefix & OLKfoldername
End Function

 

[dougmarkham]

Using recursion, you can simplify your code a bit. This will also continue to work if you add more levels.

Sub Level3()

    'Needs reference to MS Outlook Object Library
 
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olParentFolder As Outlook.MAPIFolder
    Dim olFolderA As Outlook.MAPIFolder
    Dim olFolderB As Outlook.MAPIFolder
    Dim olFolderC As Outlook.MAPIFolder
 
    Set olApp = Application 'New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")

    Set olParentFolder = olNs.Folders("Douglas.Markham@thecompany.com").Folders("Inbox")
    DrillDown olParentFolder
    Debug.Print olParentFolder.FolderPath, olParentFolder.Items.Count
End Sub

Private Function DrillDown(parentFolder As Outlook.MAPIFolder)
    Dim f As Outlook.MAPIFolder
    For Each f In parentFolder.Folders
        DrillDown f
        Debug.Print f.FolderPath, f.Items.Count
    Next
End Function

Hi Dataluver,

Thanks for this solution, it's very concise!
I like kennypete's solution for it's ability to stagger the folders and I like yours because it can print the whole path for each folder per line.

I do have one issue though: the Immediate window can only print 199 lines and my folders go somewhat beyond that number.
I've tried to print to file instead of using Debug.Print; however, I am getting the following error on the last line of the Private function below:

Please would you help me fix the error?

Sub Level3()

    'Needs reference to MS Outlook Object Library
   
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olParentFolder As Outlook.MAPIFolder
    Dim olFolderA As Outlook.MAPIFolder
    Dim olFolderB As Outlook.MAPIFolder
    Dim olFolderC As Outlook.MAPIFolder
    Dim fileNum As Integer
   
    Set olApp = Application 'New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    fileNum = FreeFile()

   Open "H:\07) Text Files\Output.txt" For Output As #fileNum


    Set olParentFolder = olNs.Folders("Douglas.Markham@theapsgroup.com").Folders("Inbox")
    DrillDown olParentFolder
    Print #fileNum, olParentFolder.FolderPath, olParentFolder.Items.Count
End Sub

Private Function DrillDown(parentFolder As Outlook.MAPIFolder)
    Dim f As Outlook.MAPIFolder
    Dim fileNum As Integer

    For Each f In parentFolder.Folders
        DrillDown f
        Print #fileNum, f.FolderPath, f.Items.Count
    Next
End Function

P.S. That DrillDown function is so nifty thanks for showing me this!

Kind regards,

Doug.

 

[dougmarkham]

The slimmed down and modified version of How to export and print list of all folders and subfolders in Outlook? below will create "tree" .csv of the selected Outlook folder, noting, of course, it is Outlook VBA, not Excel, but if you want just a .csv tree output why start within Excel at all?

I don't use subfolders, but after adding some and testing it (in Outlook Office 365 pro plus) works well - the output .csv opened in Excel below:

View attachment 4560

Dim gFileName, gBase

Public Sub ExportFolderTree()
Dim objOutlook
Dim F, Folders
Dim Result
Set objOutlook = CreateObject("Outlook.Application")
Set F = objOutlook.Session.PickFolder
If Not F Is Nothing Then
    Set Folders = F.Folders
    gFileName = GetDesktopFolder() & "\Outlook-Folders.csv"
    gBase = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
    WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
    LoopFolders Folders
    Set F = Nothing
    Set Folders = Nothing
    Set objOutlook = Nothing
End If
End Sub

Private Function GetDesktopFolder()
Dim objShell
Set objShell = CreateObject("WScript.Shell")
GetDesktopFolder = objShell.SpecialFolders("Desktop")
Set objShell = Nothing
End Function

Private Sub LoopFolders(Folders)
Dim F
For Each F In Folders
    WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
    LoopFolders F.Folders
Next
End Sub

Private Sub WriteToATextFile(OLKfoldername)
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(gFileName, 8, True)
objTextFile.WriteLine (OLKfoldername)
objTextFile.Close
Set objFSO = Nothing
Set objTextFile = Nothing

End Sub

Private Function CreateFolderTree(OLKfolderpath, OLKfoldername)
Dim i, x, OLKprefix
i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
For x = gBase To i
    OLKprefix = OLKprefix & "-,"
Next
CreateFolderTree = OLKprefix & OLKfoldername
End Function

Hi kennypete,

This code worked for me, thank you for your help .
I will have a play and see if I can set the gFileName path to a specific location, as my work PC won't let me import any excel file on the desktop.

Kind regards,

Doug.

 

[Legacy 456155]

This code worked for me, thank you for your help .

Are you good then?

 

[kennypete]

@dougmarkham if you're still interested, the following further refined and modified Outlook VBA code allows you to select the path for your .csv and also has the full paths for each folder included. It also handles commas (if there are any) in the folder names.

Option Explicit
Public gstrFileName As String

Public Sub ExportFolderTree()
Dim objOutlook As Object
Dim outFolder, outFolders
Dim objShellApp As Object
Set objOutlook = CreateObject("Outlook.Application")
Set outFolder = objOutlook.Session.PickFolder
If Not outFolder Is Nothing Then
    Set outFolders = outFolder.Folders
    Set objShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Save to folder", 0)
    gstrFileName = objShellApp.self.Path & "\Outlook-Folders.csv"
    subWriteToATextFile CreateFolderTree(outFolder.FolderPath)
    subLoopFolders outFolders
    Set outFolder = Nothing
    Set outFolders = Nothing
    Set objOutlook = Nothing
End If
End Sub
 
Private Sub subLoopFolders(outFolders)
Dim outFolder
For Each outFolder In outFolders
    subWriteToATextFile CreateFolderTree(outFolder.FolderPath)
    subLoopFolders outFolder.Folders
Next
End Sub
 
Private Sub subWriteToATextFile(strFolderName As String)
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(gstrFileName, 8, True)
objTextFile.WriteLine (strFolderName)
objTextFile.Close
Set objFSO = Nothing
Set objTextFile = Nothing
End Sub
 
Private Function CreateFolderTree(strFolderPath As String)
Dim strTree() As String
Dim intLoop
strTree = split(strFolderPath, "\")
CreateFolderTree = strTree(3) ' Presumes \\user@outlook.com\Inbox as format
If UBound(strTree) > 3 Then
    For intLoop = 4 To UBound(strTree)
        If InStr(1, strTree(intLoop), ",") > 0 Then
            CreateFolderTree = CreateFolderTree & "," & Chr(34) & strTree(intLoop) & Chr(34)
        Else
            CreateFolderTree = CreateFolderTree & "," & strTree(intLoop)
        End If
    Next intLoop
End If
End Function