Looking for a vba macro for outlook 2016 that interates through each folder and subfolder returning a list of all folders

I have an outlook vba macro the exports a list of folders & subfolders to 3 levels, but some folders can have more than three levels of subfolder

What I'd like to do is run a macro that lists all email paths (to as many levels as the user may chose to use) and then return a count of the mail items in that folder

This is the code I'm using right now

-----------------------------------
Sub Backup_PST_Process_0_IterateThruPSTFilesListingFoldersInExcel()
   Dim oMailItem As Outlook.MailItem
    Dim objMail As MailItem
    Set olApp = CreateObject("Outlook.Application")
    Set NmSpace = olApp.GetNamespace("MAPI")
    Dim IterateThroughMailItesYN As Integer

    Dim objExcel As Object
    Dim objworkbook As Object
    Dim objWorkBook1 As Workbook
    Dim objWorksheet As Object
    Dim colContacts As Object
    Dim objNameSpace As Object
    Dim objOutlook As Object
    Dim objContact As Object
    Dim objRange As Object
   
    Dim i As Integer
    Dim RowNo As Integer
    Dim X As Integer, Z As Integer, j As Integer, k As Integer, l As Integer '12-31-2017b
    Dim NumberOfEmails As Double, LastSent As Date, LastReceived As Date
       
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
    Set objWorksheet = objWorkBook1.Worksheets("folders")
   
    objExcel.Sheets("Folders").Select
    objExcel.Range("b1").Select

    objExcel.Columns("B:h").Select
    objExcel.Selection.ClearContents
   
    RowNo = 1
    objExcel.Cells(RowNo, 2) = "PST FILE"
    objExcel.Cells(RowNo, 3) = "Folder Level 1 Name"
    objExcel.Cells(RowNo, 4) = "Folder Level 2 Name"
    objExcel.Cells(RowNo, 5) = "Folder Level 3 Name"
    objExcel.Cells(RowNo, 6) = "Number of Mail Items"
    objExcel.Cells(RowNo, 7) = "Last Email Date"
    objExcel.Cells(RowNo, 10) = "Dest Pst File Date"

    RowNo = RowNo + 1
   
'09-03-2017    IterateThroughMailItesYN = MsgBox("Do You Want To Iterate through Each Email in all Folders", vbYesNo)
   
    UserForm2.Show
    If Userform2Val = 0 Then
        IterateThroughMailItesYN = 7
    Else
        IterateThroughMailItesYN = 6
    End If
   
   
'09-03-2017------------------------------

    X = 1
    Z = 1
    k = 1
    l = 1 '12-31-2017b
    j = 1 '12-31-2017b
   
    For i = 1 To NmSpace.Folders.Count '''PST Level
        Set mailbox1 = NmSpace.Folders(i)
       
        objExcel.Cells(RowNo, 2) = mailbox1.Name
       
        RowNo = RowNo + 1

        If Z = 1 And IterateThroughMailItesYN = 6 Then '07-05-2014
           
            Z = 0
           
            LastSent = #1/1/1900#
            LastReceived = #1/1/1900#
           
            NumberOfEmails = 0
           
            For Each Item In mailbox1.Items
                Set MailItem = Item
                Set MItem = Item '06-23-2011
           
                If InStr(MailItem.Subject, "MyString") <> 0 Then
                    MsgBox "(4) Mail found in " & mailbox1 & " \ " & mailbox2 & " \ " & mailbox3 & " with subject" & "MyString"
                End If
               
                NumberOfEmails = NumberOfEmails + 1
                On Error Resume Next
                    If MailItem.SentOn > LastSent Then LastSent = MailItem.SentOn
                    If MailItem.ReceivedTime > LastReceived Then LastReceived = MailItem.ReceivedTime
                On Error GoTo 0
           
                UserForm1.TextBox1 = "Folder 1 z = " & Z & " j = " & j & vbNewLine & vbNewLine & mailbox1.Name '& vbNewLine & mailbox2.Name
                UserForm1.TextBox2 = "NumberOfEmails = " & NumberOfEmails & " LastSent = " & LastSent & " LastReceived = " & LastReceived
                UserForm1.Show vbModeless
                DoEvents
               
            Next
       
            objExcel.Cells(RowNo, 6) = NumberOfEmails
           
            If LastSent > LastReceived Then
                objExcel.Cells(RowNo, 7) = Int(LastSent)
            Else
                objExcel.Cells(RowNo, 7) = Int(LastReceived)
            End If
           
            On Error Resume Next
                objExcel.Cells(RowNo, 10) = FileDateTime("J:\Personal\OutlookData\" & objExcel.Cells(RowNo, 9) & ".pst")
            On Error GoTo 0
       
        End If '07-05-2014
       
        RowNo = RowNo + 1
           
        For j = 1 To mailbox1.Folders.Count
            Set mailbox2 = mailbox1.Folders(j) ''folder level 1
           
            objExcel.Cells(RowNo, 2) = mailbox1.Name
            objExcel.Cells(RowNo, 3) = mailbox2.Name
           
            objExcel.Cells(RowNo, 6) = mailbox2.Items.Count + mailbox1.Items.Count
           
            If X = 1 And IterateThroughMailItesYN = 6 Then '07-05-2014
               
                X = 0
               
                LastSent = #1/1/1900#
                LastReceived = #1/1/1900#
               
                NumberOfEmails = 0
               
                For Each Item In mailbox2.Items
                    Set MailItem = Item
                    Set MItem = Item '06-23-2011

                    If InStr(MailItem.Subject, "MyString") <> 0 Then
                        MsgBox "(4) Mail found in " & mailbox1 & " \ " & mailbox2 & " \ " & mailbox3 & " with subject" & "MyString"
                    End If

                    NumberOfEmails = NumberOfEmails + 1
                    On Error Resume Next
                        If MailItem.SentOn > LastSent Then LastSent = MailItem.SentOn
                        If MailItem.ReceivedTime > LastReceived Then LastReceived = MailItem.ReceivedTime
                    On Error GoTo 0

                    UserForm1.TextBox1 = "Folder 2 x = " & X & " j = " & j & vbNewLine & vbNewLine & mailbox1.Name & vbNewLine & mailbox2.Name
                    UserForm1.TextBox2 = "NumberOfEmails = " & NumberOfEmails & " LastSent = " & LastSent & " LastReceived = " & LastReceived
                    UserForm1.Show vbModeless
                    DoEvents
 On Error Resume Next

                Next

'01-05-2016 Testing TimeFound:
                objExcel.Cells(RowNo, 6) = NumberOfEmails

                If LastSent > LastReceived Then
                    objExcel.Cells(RowNo, 7) = Int(LastSent)
                Else
                    objExcel.Cells(RowNo, 7) = Int(LastReceived)
                End If

                On Error Resume Next
                    objExcel.Cells(RowNo, 10) = FileDateTime("J:\Personal\OutlookData\" & objExcel.Cells(RowNo, 9) & ".pst")
                On Error GoTo 0
       
                RowNo = RowNo + 1
           
            End If '07-05-2014
           
                    RowNo = RowNo + 1
           
                    If mailbox2.Folders.Count > 0 Then
                        For k = 1 To mailbox2.Folders.Count
                            Set mailbox3 = mailbox2.Folders(k)
                           
                            objExcel.Cells(RowNo, 2) = mailbox1.Name
                            objExcel.Cells(RowNo, 3) = mailbox2.Name
                            objExcel.Cells(RowNo, 4) = mailbox3.Name
               
                            objExcel.Cells(RowNo, 6) = mailbox3.Items.Count + mailbox2.Items.Count + mailbox1.Items.Count
                           
                            If IterateThroughMailItesYN = 6 Then '07-05-2014
                               
                                LastSent = #1/1/1900#
                                LastReceived = #1/1/1900#
                               
                                NumberOfEmails = 0
                               
                                For Each Item In mailbox3.Items
                                    Set MailItem = Item
                                    Set MItem = Item '06-23-2011

                                    If InStr(MailItem.Subject, "MyString") <> 0 Then
                                        MsgBox "(4) Mail found in " & mailbox1 & " \ " & mailbox2 & " \ " & mailbox3 & " with subject" & "MyString"
                                    End If

                                    NumberOfEmails = NumberOfEmails + 1
                                    On Error Resume Next
                                        If MailItem.SentOn > LastSent Then LastSent = MailItem.SentOn
                                        If MailItem.ReceivedTime > LastReceived Then LastReceived = MailItem.ReceivedTime
                                    On Error GoTo 0

                                    UserForm1.TextBox1 = mailbox1.Name & vbNewLine & mailbox2.Name & vbNewLine & mailbox3.Name
                                    UserForm1.TextBox2 = "NumberOfEmails = " & NumberOfEmails & " LastSent = " & LastSent & " LastReceived = " & LastReceived
                                    UserForm1.Show vbModeless
                                    DoEvents
                                Next

'01-05-2016 Testing TimeFound1:
                                objExcel.Cells(RowNo, 6) = NumberOfEmails

                                If LastSent > LastReceived Then
                                    objExcel.Cells(RowNo, 7) = Int(LastSent)
                                Else
                                    objExcel.Cells(RowNo, 7) = Int(LastReceived)
                                End If
                               
                                On Error Resume Next
                                    objExcel.Cells(RowNo, 10) = FileDateTime("J:\Personal\OutlookData\" & objExcel.Cells(RowNo, 9) & ".pst")
                                On Error GoTo 0
       
                                RowNo = RowNo + 1
                               

                           
                            End If '07-05-2014
                           
                            UserForm1.Hide
                           
'On Error GoTo 0
'
'MsgBox objExcel.Cells(RowNo, 3) & " - " & objExcel.Cells(RowNo, 4) & " - " & objExcel.Cells(RowNo, 5) & vbNewLine & vbNewLine & objExcel.Cells(RowNo, 10)

                            On Error Resume Next
                                objExcel.Cells(RowNo, 10) = FileDateTime("J:\Personal\OutlookData\" & objExcel.Cells(RowNo, 9) & ".pst")
                            On Error GoTo 0
       
                            If IterateThroughMailItesYN = 7 Then RowNo = RowNo + 1
                           
                        '12-31-2017b------------------------------------
                                     l = 1 '12-31-2017c
                                     
                                     If mailbox3.Folders.Count > 0 Then
                                        For l = 1 To mailbox3.Folders.Count '12-31-2017b
                                            Set mailbox4 = mailbox3.Folders(l) '12-31-2017b
                                           
                                            objExcel.Cells(RowNo, 2) = mailbox1.Name
                                            objExcel.Cells(RowNo, 3) = mailbox2.Name
                                            objExcel.Cells(RowNo, 4) = mailbox3.Name
                                            objExcel.Cells(RowNo, 5) = mailbox4.Name
                               
                                            objExcel.Cells(RowNo, 6) = mailbox4.Items.Count + mailbox2.Items.Count + mailbox1.Items.Count
                                           
                                            If IterateThroughMailItesYN = 6 Then
                                               
                                                LastSent = #1/1/1900#
                                                LastReceived = #1/1/1900#
                                               
                                                NumberOfEmails = 0
                                               
                                                For Each Item In mailbox4.Items
                                                    Set MailItem = Item
                                                    Set MItem = Item
               
                                                    If InStr(MailItem.Subject, "MyString") <> 0 Then
                                                        MsgBox "(5) Mail found in " & mailbox1 & " \ " & mailbox2 & " \ " & mailbox3 & " \ " & mailbox4 & " with subject" & "MyString"
                                                    End If
               
                                                    NumberOfEmails = NumberOfEmails + 1
                                                    On Error Resume Next
                                                        If MailItem.SentOn > LastSent Then LastSent = MailItem.SentOn
                                                        If MailItem.ReceivedTime > LastReceived Then LastReceived = MailItem.ReceivedTime
                                                    On Error GoTo 0
               
                                                    UserForm1.TextBox1 = mailbox1.Name & vbNewLine & mailbox2.Name & vbNewLine & mailbox3.Name & vbNewLine & mailbox4.Name
                                                    UserForm1.TextBox2 = "NumberOfEmails = " & NumberOfEmails & " LastSent = " & LastSent & " LastReceived = " & LastReceived
                                                    UserForm1.Show vbModeless
                                                    DoEvents
                                                Next
               
                                                objExcel.Cells(RowNo, 6) = NumberOfEmails
               
                                                If LastSent > LastReceived Then
                                                    objExcel.Cells(RowNo, 7) = Int(LastSent)
                                                Else
                                                    objExcel.Cells(RowNo, 7) = Int(LastReceived)
                                                End If
                                               
                                                On Error Resume Next
                                                    objExcel.Cells(RowNo, 10) = FileDateTime("J:\Personal\OutlookData\" & objExcel.Cells(RowNo, 9) & ".pst")
                                                On Error GoTo 0
                       
                                            End If
                                           
                                            RowNo = RowNo + 1
                                       
                                        Next
                                    End If
           
'12-31-2017b-------------------------------------------------

                       
                        Next
                    End If


            With objWorksheet
                .Columns("a").AutoFit
                .Columns("b").AutoFit
                .Columns("c").AutoFit
                .Columns("d").AutoFit
                .Columns("e").AutoFit
                .Columns("f").AutoFit
                .Columns("g").AutoFit
                .Columns("h").AutoFit
                .Columns("i").AutoFit
                .Columns("j").AutoFit
            End With
       
            X = 1
            Z = 1
            k = 1
        Next
    Next
   
    objWorksheet.Cells.Select
    objWorksheet.Sort.SortFields.Clear
    objWorksheet.Sort.SortFields.Add Key:=Range("B1:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    objWorksheet.Sort.SortFields.Add Key:=Range("C1:C2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    objWorksheet.Sort.SortFields.Add Key:=Range("D1:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    objWorksheet.Sort.SortFields.Add Key:=Range("E1:E2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With objWorksheet.Sort
        .SetRange Range("A1:az2000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'09-03-2017 ----------------------

   
    objExcel.Sheets("BackupPstFileNames").Select
        Columns("A:D").Select
        Range("D1").Activate
        Selection.ClearContents
   
    objExcel.Sheets("Folders").Select
        Columns("A:D").Select
        Range("D1").Activate
        Selection.Copy
   
    objExcel.Sheets("BackupPstFileNames").Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Cells.Select

        objExcel.CutCopyMode = False
       
    Set objWorksheet = objWorkBook1.Worksheets("BackupPstFileNames")
        objWorksheet.Sort.SortFields.Clear
        objWorksheet.Sort.SortFields.Add Key:=Range("A2:A648"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        objWorksheet.Sort.SortFields.Add Key:=Range("F2:F648"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   
    With objWorksheet.Sort
        .SetRange Range("A1:W648")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
        objExcel.Sheets("BackupPstFileNames").Select
       
        Range("E2:E5000").Select
        Selection.ClearContents
       
        Range("M2:M5000").Select
        Selection.ClearContents
       
        Range("P2:P5000").Select
        Selection.ClearContents
       
        Range("Q2:Q5000").Select
        Selection.ClearContents
       
        Range("R2:r5000").Select
        Selection.ClearContents
       
        Range("S2:s5000").Select
        Selection.ClearContents

'Dim RowNo As Integer
   
        Range("A2").Select
        Selection.End(xlDown).Select
        objExcel.CutCopyMode = False
        RowNo = Selection.Row
       
        Columns("A:D").Select
        Range("D1").Activate
        Selection.ColumnWidth = 30
   
        Range("E2").Select
        objExcel.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=R[-1]C"
        Range("E2").Select
        Selection.Copy
        Range("E2:E" & RowNo).Select
        objWorksheet.Paste
       
        Range("F2").Select
        objExcel.CutCopyMode = False
        Selection.Copy
        Range("f2:f" & RowNo).Select
        objWorksheet.Paste
        Range("F2").Select
   

'09-03-2017



    objWorkBook1.Save
    objWorkBook1.SaveAs ("j:\Personal\OutlookData\" & objWorkBook1.Name & " " & Format(Now(), "yyyy-mm-dd") & ".xlsm")
    objWorkBook1.Close savechanges:=True
    objExcel.Quit
    Set objExcel = Nothing
End Sub
rogerdjrAsked:
Who is Participating?
 
Neil FlemingConsultant and developerCommented:
I think you basically just need an iteratively-called routine.

The following is the simplest approach:
  1. A routine that initiates the folder search
  2. An iterative routine that "calls itself" to search all sub-folders of sub-folders

Routine 1 would look like this:
 Sub listAllFolders()
 Dim ns As Outlook.NameSpace
 Dim exp As Explorer
 Dim ff As Outlook.Folder
 
 Set ns = Application.GetNamespace("MAPI")
 Set exp = ActiveExplorer
 For Each ff In ns.Folders
 GetFolderDetails ff
 Next
 End Sub

Open in new window


Routine 2 is the "GetFolderDetails" routine called above. In my example it just outputs what you want to the "Immediate" window in the vb code window, but can be easily changed to list what you want in Excel or elsewhere.

The key is the line where the routine "calls itself" to get details of the next subfolder.

Sub GetFolderDetails(ff As Folder)
 Dim subf As Outlook.Folder
 'replace this with your Excel export code:
 Debug.Print ff.FolderPath
 Debug.Print "Items:" & ff.Items.Count
 Debug.Print "--------------"
 
    'iterate all subfolders
    For Each subf In ff.Folders
    'call self:
    GetFolderDetails subf
    Next
 End Sub

Open in new window

0
 
rogerdjrAuthor Commented:
Great solution - thanks a lot
0
 
rogerdjrAuthor Commented:
Great solution thanks for the help
1
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
Neil FlemingConsultant and developerCommented:
My pleasure
0
 
rogerdjrAuthor Commented:
Feeling a little perplexed - added free file process to write to a text file and it works great

Added excel process and it keeps jamming up with an error message "Run-time error 91" Object variable or with block variable not set

error appears at "objExcel.Sheets("New Folder List").Select"

Would appreciate a little more help

    Public RowNo As Integer
 Sub listAllFolders()
    Dim ns As Outlook.NameSpace
    Dim exp As Explorer
    Dim ff As Outlook.Folder
   
    Dim objExcel As Object
    Dim objworkbook As Object
    Dim objWorkBook1 As Workbook
    Dim objWorksheet As Object

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
    Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
   
    objExcel.Sheets("New Folder List").Select
    objExcel.Range("a1").Select
   
    RowNo = 1
    objExcel.Cells(RowNo, 1) = "PST FOLDER"
    objExcel.Cells(RowNo, 2) = "Number of Mail Items"
   
    objWorkBook1.Close savechanges:=True
    objExcel.Quit
    Set objExcel = Nothing

    Dim TextFile As Integer
    Dim FilePath As String
   
    'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now, "yyyy-mm-dd") & ".txt"
   
    'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile
   
    'Open the text file
    Open FilePath For Output As TextFile
   
    'Write some lines of text
    Print #TextFile, "Start"
     
    'Save & Close Text File
    Close TextFile
 
    Set ns = Application.GetNamespace("MAPI")
    Set exp = ActiveExplorer
   
    For Each ff In ns.Folders
        GetFolderDetails ff
    Next
 End Sub

Sub GetFolderDetails(ff As Folder)
    Dim subf As Outlook.Folder

    'replace this with your Excel export code:
    Debug.Print ff.FolderPath
    Debug.Print "Items:" & ff.Items.Count
    Debug.Print "--------------"
 
    If RowNo = 1 Then
        Dim objExcel As Object
        Dim objworkbook As Object
        Dim objWorkBook1 As Workbook
        Dim objWorksheet As Object

        Set objExcel = CreateObject("Excel.Application")
        objExcel.Visible = True
        Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
        Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
   
        objExcel.Sheets("New Folder List").Select
        objExcel.Range("a1").Select
    End If
   
    RowNo = RowNo + 1
 
    objExcel.Sheets("New Folder List").Select
    objExcel.Cells(RowNo, 1) = ff.FolderPath
    objExcel.Cells(RowNo, 2) = ff.Items.Count
   
    Dim TextFile As Integer
    Dim FilePath As String

'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now(), "yyyy-mm-dd") & ".txt"

'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile

'Open the text file
    Open FilePath For Append As TextFile

'Write some lines of text
    Print #TextFile, ff.FolderPath
 
'Save & Close Text File
    Close TextFile
 
    'iterate all subfolders
    For Each subf In ff.Folders
        'call self:
        GetFolderDetails subf
    Next
 End Sub
0
 
Neil FlemingConsultant and developerCommented:
You used the "ObjExcel" object to try to select the sheet. But ObjExcel is the application, rather than the workbook.

Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
    objExcel.Sheets("New Folder List").Select ''THIS WILL NOT WORK -- "SHEETS" is not a properly of the application

Open in new window


Since you have an object for the worksheet already, I would rewrite as:
Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
objWorksheet.Activate
objWorksheet.Range("a1").Select

Open in new window

0
 
Neil FlemingConsultant and developerCommented:
As a PS: you do not actually need to activate the "new folder list" worksheet, nor select any cells in it. This will simply slow down the process.

I would open the "new folder list" workbook in your master routine and simply output to it from GetFolderDetails, using:
 objWorksheet.Cells(RowNo, 1) = ff.FolderPath
    objWorksheet.Cells(RowNo, 2) = ff.Items.Count

Open in new window


That means you need to declare the objWorksheet object at "module level" rather than in the routine.
0
 
rogerdjrAuthor Commented:
Getting close

at  objWorksheet.Cells(RowNo, 1) = ff.FolderPath I get an error message Run Time Error 424 Object required

Edits I made are -

    Public RowNo As Integer
 Sub listAllFolders()
    Dim ns As Outlook.NameSpace
    Dim exp As Explorer
    Dim ff As Outlook.Folder
   
    Dim objExcel As Object
    Dim objworkbook As Object
    Dim objWorkBook1 As Workbook
    Dim objWorksheet As Object

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
    Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
   
''    objExcel.Sheets("New Folder List").Select
''    objExcel.Range("a1").Select
   
    RowNo = 1
''    objExcel.Cells(RowNo, 1) = "PST FOLDER"
''    objExcel.Cells(RowNo, 2) = "Number of Mail Items"
   
    objWorksheet.Cells(RowNo, 1) = "PST FOLDER"
    objWorksheet.Cells(RowNo, 2) = "Number of Mail Items"
   
''    objWorkBook1.Close savechanges:=True
''    objExcel.Quit
''    Set objExcel = Nothing

    Dim TextFile As Integer
    Dim FilePath As String
   
    'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now, "yyyy-mm-dd") & ".txt"
   
    'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile
   
    'Open the text file
    Open FilePath For Output As TextFile
   
    'Write some lines of text
    Print #TextFile, "Start"
     
    'Save & Close Text File
    Close TextFile
 
    Set ns = Application.GetNamespace("MAPI")
    Set exp = ActiveExplorer
   
    For Each ff In ns.Folders
        GetFolderDetails ff
    Next
 End Sub

Sub GetFolderDetails(ff As Folder)
    Dim subf As Outlook.Folder

    'replace this with your Excel export code:
    Debug.Print ff.FolderPath
    Debug.Print "Items:" & ff.Items.Count
    Debug.Print "--------------"
 
''    If RowNo = 1 Then
''        Dim objExcel As Object
''        Dim objworkbook As Object
''        Dim objWorkBook1 As Workbook
''        Dim objWorksheet As Object
''
''        Set objExcel = CreateObject("Excel.Application")
''        objExcel.Visible = True
''        Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
''        Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
''
''        objExcel.Sheets("New Folder List").Select
''        objExcel.Range("a1").Select
''    End If
   
    RowNo = RowNo + 1
 
''    Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
''    objWorksheet.Activate
''    objWorksheet.Range("a1").Select
    objWorksheet.Cells(RowNo, 1) = ff.FolderPath
    objWorksheet.Cells(RowNo, 2) = ff.Items.Count
   
''    objExcel.Sheets("New Folder List").Select
''    objExcel.Cells(RowNo, 1) = ff.FolderPath
''    objExcel.Cells(RowNo, 2) = ff.Items.Count
   
    Dim TextFile As Integer
    Dim FilePath As String

'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now(), "yyyy-mm-dd") & ".txt"

'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile

'Open the text file
    Open FilePath For Append As TextFile

'Write some lines of text
    Print #TextFile, ff.FolderPath
 
'Save & Close Text File
    Close TextFile
 
    'iterate all subfolders
    For Each subf In ff.Folders
        'call self:
        GetFolderDetails subf
    Next
 End Sub
0
 
rogerdjrAuthor Commented:
Got it working - here is the finished code Thanks again

    Public RowNo As Integer
    Public objWorksheet As Object

 Sub listAllFolders()
    Dim ns As Outlook.NameSpace
    Dim exp As Explorer
    Dim ff As Outlook.Folder
   
    Dim objExcel As Object
    Dim objworkbook As Object
    Dim objWorkBook1 As Workbook

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objWorkBook1 = objExcel.Workbooks.Open("j:\Personal\OutlookData\Transfer Outlook Folders.xlsm")
    Set objWorksheet = objWorkBook1.Worksheets("New Folder List")
   
    RowNo = 1
   
    objWorksheet.Cells(RowNo, 1) = "PST FOLDER"
    objWorksheet.Cells(RowNo, 2) = "Number of Mail Items"
   
    Dim TextFile As Integer
    Dim FilePath As String
   
    'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now, "yyyy-mm-dd") & ".txt"
   
    'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile
   
    'Open the text file
    Open FilePath For Output As TextFile
   
    'Write some lines of text
    Print #TextFile, "Start"
     
    'Save & Close Text File
    Close TextFile
 
    Set ns = Application.GetNamespace("MAPI")
    Set exp = ActiveExplorer
   
    For Each ff In ns.Folders
        GetFolderDetails ff
    Next
 
''    objWorkBook1.Close savechanges:=True
''    objExcel.Quit
''    Set objExcel = Nothing
 
 End Sub

Sub GetFolderDetails(ff As Folder)
    Dim subf As Outlook.Folder

    'replace this with your Excel export code:
    Debug.Print ff.FolderPath
    Debug.Print "Items:" & ff.Items.Count
    Debug.Print "--------------"
 
   
    RowNo = RowNo + 1
 
    objWorksheet.Activate
''    objWorksheet.Range("a1").Select
    objWorksheet.Cells(RowNo, 1) = ff.FolderPath
    objWorksheet.Cells(RowNo, 2) = ff.Items.Count
   
    Dim TextFile As Integer
    Dim FilePath As String

'What is the file path and name for the new text file?
    FilePath = "J:\Personal\OutlookData\ListOfFolders" & Format(Now(), "yyyy-mm-dd") & ".txt"

'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile

'Open the text file
    Open FilePath For Append As TextFile

'Write some lines of text
    Print #TextFile, ff.FolderPath
 
'Save & Close Text File
    Close TextFile
 
    'iterate all subfolders
    For Each subf In ff.Folders
        'call self:
        GetFolderDetails subf
    Next
 End Sub
0
 
Neil FlemingConsultant and developerCommented:
glad to be of help.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.