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.
Mike on Mar. 1, 2013:
Your logic and explanantions were very helpful. Look forward to hearing from you
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
