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.

For a version in a page by itself (i.e., not in a scrollable iframe as below) visit http://www.tushar-mehta.com/publish_train/xl_vba_cases/1201%20Outlook%20folder%20info.shtml

Tushar Mehta

Posted in Uncategorized

5 thoughts on “List all folders in a Microsoft Outlook account

  1. Sub mappen_Outlookmappenstruktuur()
    For Each fld In CreateObject("outlook.Application").GetNamespace("MAPI").Folders
    c01 = c01 & vbCr & fld.Name

    For Each fld1 In fld.Folders
    c01 = c01 & vbCr & fld1.Name & "|" & fld1.Size & "|" & fld1.Items.Count
    For Each fld2 In fld1.Folders
    c01 = c01 & vbCr & "|" & fld2.Name & "|" & fld2.Items.Count
    Next
    Next
    Next

    Cells(1).Resize(UBound(Split(c01, vbCr))) = Application.Transpose(Split(Mid(c01, 2), vbCr))
    Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
    End Sub

  2. Sub Add_Checkdigit()

    lastrow = ActiveSheet.UsedRange.Rows.Count
    Range(Cells(2, “A”), Cells(lastrow, “A”)).Select
    With Selection
    Set c = .Find(“”, LookIn:=xlValues)
    If Not c Is Nothing Then
    lastrow = c.Row – 1
    End If
    End With
    Range(Cells(2, “A”), Cells(lastrow, “A”)).Select

    If Selection.Rows.Count = 1 Then
    ReDim Data(1, 1)
    Data(1, 1) = Selection
    Else
    Data = Selection
    End If
    For x = 1 To UBound(Data)
    strContainerNumber = Data(x, 1)

    ‘check for missing leading zero

    For A = 1 To 4
    checker = Mid(strContainerNumber, A, 1)
    If IsNumeric(Val(checker)) Then b = b + 1
    Next
    If b > 1 Then
    If Len(Mid(strContainerNumber, 5)) = 5 And IsNumeric(Mid(strContainerNumber, 5)) Then
    strContainerNumber = Left(strContainerNumber, 4) & “0” & Right(strContainerNumber, 5)
    End If
    End If

    If Len(strContainerNumber) >= 11 Or Len(strContainerNumber) < 9 Then 'exit function if check digit is already included
    'Exit For
    Else
    'declarations
    Dim strDigit As String
    Dim intDigitValue As Integer
    Dim lngTotalDigitValue As Long
    Dim intCheckDigit As Integer
    Dim intLoopCounter As Integer
    Dim intMultiplier As Integer

    Let intLoopCounter = 1
    Let intMultiplier = 1
    Let lngTotalDigitValue = 0

    'get total digit value
    Do While intLoopCounter <= 10
    Let strDigit = UCase(Mid(strContainerNumber, intLoopCounter, 1))
    Select Case strDigit
    Case "A"
    Let intDigitValue = 10
    Case "B"
    Let intDigitValue = 12
    Case "C"
    Let intDigitValue = 13
    Case "D"
    Let intDigitValue = 14
    Case "E"
    Let intDigitValue = 15
    Case "F"
    Let intDigitValue = 16
    Case "G"
    Let intDigitValue = 17
    Case "H"
    Let intDigitValue = 18
    Case "I"
    Let intDigitValue = 19
    Case "J"
    Let intDigitValue = 20
    Case "K"
    Let intDigitValue = 21
    Case "L"
    Let intDigitValue = 23
    Case "M"
    Let intDigitValue = 24
    Case "N"
    Let intDigitValue = 25
    Case "O"
    Let intDigitValue = 26
    Case "P"
    Let intDigitValue = 27
    Case "Q"
    Let intDigitValue = 28
    Case "R"
    Let intDigitValue = 29
    Case "S"
    Let intDigitValue = 30
    Case "T"
    Let intDigitValue = 31
    Case "U"
    Let intDigitValue = 32
    Case "V"
    Let intDigitValue = 34
    Case "W"
    Let intDigitValue = 35
    Case "X"
    Let intDigitValue = 36
    Case "Y"
    Let intDigitValue = 37
    Case "Z"
    Let intDigitValue = 38
    Case "0"
    Let intDigitValue = 0
    Case "1"
    Let intDigitValue = 1
    Case "2"
    Let intDigitValue = 2
    Case "3"
    Let intDigitValue = 3
    Case "4"
    Let intDigitValue = 4
    Case "5"
    Let intDigitValue = 5
    Case "6"
    Let intDigitValue = 6
    Case "7"
    Let intDigitValue = 7
    Case "8"
    Let intDigitValue = 8
    Case "9"
    Let intDigitValue = 9
    End Select
    Let lngTotalDigitValue = intDigitValue * intMultiplier + lngTotalDigitValue
    Let intLoopCounter = intLoopCounter + 1
    Let intMultiplier = intMultiplier + intMultiplier
    Loop

    'divid the total digit value by 11. the remainder is the check digit
    Let intCheckDigit = lngTotalDigitValue Mod 11
    'if the check remainder equals 10 then the check digit is 0
    If intCheckDigit = 10 Then
    Let intCheckDigit = 0
    End If

    'combind the container number and the check digit
    Data(x, 1) = UCase(strContainerNumber) & intCheckDigit
    End If
    Next
    If Selection.Rows.Count = 1 Then
    Selection = Data(1, 1)
    Else
    Selection = Data
    End If

    End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *