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

Paste this code in:

Outlook VB or Excel VB ?

Excel.

`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

The best place I have found so far for anything related to Outlook vba is Sue Mosher’s web site:

http://www.outlookcode.com/

Lots of useful examples can be found in:

http://www.outlookcode.com/member/jump2007.zip

One of them seems to correspond to your issue: Listing 13.11 – List the folders and number of items in the current Outlook session (VBA).

Bert

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