Home > Publications & Training > Case Studies > MS Outlook folder list
Google
Web This Site

List all folders in a Microsoft Outlook account

Recently, I wanted to create a list of all the folders in my MS Outlook PST file together with the size of each folder.  Outlook provides that information through the user interface.  Unfortunately, it shows the result in a modal dialog with no way to save the information elsewhere.  So, I decided to check if I could find some ready-to-use (or nearly ready-to-use) code that did the needful.  A search of the web led to several ideas and suggestions but no code to do the needful.  So, I decided to put together a VBA module that would save the information in an Excel worksheet.

One caveat: I am not an Outlook expert.  The code below works for me.  I use Outlook with a single profile, a single PST file in that profile, and the PST file is on a local drive – my mail, calendar, and contacts are in that file and not on a server.  So, whether the below will work with a different configuration is something you will have to check for yourself.

The result of the code below matches what Outlook shows in the dialog box that lists folders and their respective sizes.  So, at least for me it works as intended both with Outlook 2007 and Outlook 2010 64bit.

Performance leaves something to be desired.  In the Outlook object model, folders don’t contain size information.  So, the code has to go through every item in every folder to accumulate the necessary data.

Recent Comments

Mike on Mar. 1, 2013:

Your logic and explanantions were very helpful.  Look forward to hearing from you

 

Implementation

The core routine is a recursive subroutine that processes a single Outlook folder.  It calls itself for each subfolder contained in that folder.  The result will be in a new worksheet in the active workbook and if that is not possible in a new worksheet in a new workbook.  The result will be grouped using the Excel Group Outline feature based on the depth of the Outlook folder hierarchy.

To use the code, first copy it into the appropriate code module as described below.  Then, use ALT+F8 to bring up the Macro dialog box.  In there, select and run the OLFolderSize subroutine.

The code goes into two modules.  In a class module named clsGroupInfo enter the following:

Option Explicit

 

Public StartIdx As Long, EndIdx As Long, Name As String

 

In a standard module enter the following:

Option Explicit

Option Base 0

#Const EarlyBind = False

 

Function ArrLen(Arr, Optional ByVal WhichDim As Integer = 1) As Long

    ArrLen = UBound(Arr, WhichDim) - LBound(Arr, WhichDim) + 1

    End Function

Function getDestWS() As Worksheet

    Dim WS As Worksheet

    On Error Resume Next

    Set WS = ActiveWorkbook.Worksheets.Add()

    If WS Is Nothing Then _

        Set WS = Workbooks.Add().Worksheets.Add()

    On Error GoTo 0

    Set getDestWS = WS

    End Function

#If EarlyBind Then

Sub getAFolderInfo(ByVal NestLevel As Integer, _

        ByVal aFolder As Outlook.Folder, ByRef Rslt(), _

        ByRef AllGroups As Collection)

#Else

Sub getAFolderInfo(ByVal NestLevel As Integer, _

        ByVal aFolder As Object, ByRef Rslt(), _

        ByRef AllGroups As Collection)

    #End If

    Application.StatusBar = aFolder.FolderPath

    Dim I As Long: I = UBound(Rslt, 2) + 1

    Dim aGroup As clsGroupInfo: Set aGroup = New clsGroupInfo

    aGroup.StartIdx = I: aGroup.Name = aFolder.Name

    ReDim Preserve Rslt(UBound(Rslt), I)

    Rslt(0, I) = aFolder.Name

    Rslt(1, I) = aFolder.FolderPath

    Rslt(2, I) = NestLevel

    Dim anItem As Object, NbrItems As Long, FolderSize As Long

    For Each anItem In aFolder.Items

        NbrItems = NbrItems + 1

        FolderSize = FolderSize + anItem.Size

        Next anItem

    Rslt(3, I) = NbrItems

    Rslt(4, I) = FolderSize

    Rslt(5, I) = FolderSize 'foldersize incl. subfolders

    Rslt(6, I) = I

    #If EarlyBind Then

    Dim aSubFolder As Outlook.Folder

    #Else

    Dim aSubFolder As Object

        #End If

    For Each aSubFolder In aFolder.Folders

        Dim ChildRow As Long: ChildRow = UBound(Rslt, 2) + 1

        getAFolderInfo NestLevel + 1, aSubFolder, Rslt, AllGroups

        Rslt(5, I) = Rslt(5, I) + Rslt(5, ChildRow)

        Next aSubFolder

    aGroup.EndIdx = UBound(Rslt, 2)

    AllGroups.Add aGroup, aGroup.StartIdx & "-" & aGroup.EndIdx

    End Sub

Sub createGroups(WS As Worksheet, AllGroups As Collection)

    Dim aGroup As clsGroupInfo

    WS.Outline.SummaryRow = xlSummaryAbove

    For Each aGroup In AllGroups

        With aGroup

        If .StartIdx > 2 Then _

            WS.Rows(.StartIdx + 1).Resize(.EndIdx - .StartIdx + 1).Group

            End With

        Next aGroup

    End Sub

Sub OLFolderSize()

   

    Dim WS As Worksheet

    Set WS = getDestWS()

    If WS Is Nothing Then _

        MsgBox "Unable to create a result worksheet! :(": Exit Sub

   

    Dim Rslt(): ReDim Rslt(6, 1)

    Rslt(0, 0) = "Start": Rslt(1, 0) = Now()

    Rslt(0, 1) = "Name"

    Rslt(1, 1) = "Path"

    Rslt(2, 1) = "Depth"

    Rslt(3, 1) = "Item Count"

    Rslt(4, 1) = "Folder Size"

    Rslt(5, 1) = "Size incl. subfolders"

    Rslt(6, 1) = "Unique ID"

    Dim AllGroups As Collection: Set AllGroups = New Collection

    #If EarlyBind Then

    Dim OL As Outlook.Application, NS As Outlook.Namespace, _

        aFolder As Outlook.Folder

    #Else

    Dim OL As Object, NS As Object, aFolder As Object

        #End If

    Set OL = CreateObject("outlook.application")

    Set NS = OL.GetNamespace("MAPI")

    For Each aFolder In NS.Folders

        getAFolderInfo 0, aFolder, Rslt, AllGroups

        Next aFolder

    Rslt(2, 0) = "Complete": Rslt(3, 0) = Now()

    With WS

    .Cells(1, 1).Resize(ArrLen(Rslt, 2), ArrLen(Rslt, 1)) = _

        Application.WorksheetFunction.Transpose(Rslt)

    .Columns(1).Resize(, ArrLen(Rslt, 1)).NumberFormat = "#,##0"

    .Rows(1).NumberFormat = "hh:mm:ss"

        End With

    Application.StatusBar = False

    createGroups WS, AllGroups

    End Sub

 

 

 

Share Your Comments