Loop Through Outlook Folders using vba

Posted on 2007-12-01
Last Modified: 2013-11-27
I'm missing something in my code... It is not looping further into subfolders (as the msgbox states).
Can you please advise what's missing?  Thanks!

Private Sub cmdEmailFolders2_Click()
'12/1/07 outlook folders button
Dim y As Integer
Dim outApp As New outlook.Application
Dim nsp As outlook.NameSpace
Dim mpf As outlook.MAPIFolder
Dim mpfSubFolder As outlook.MAPIFolder
Dim flds As outlook.Folders
Dim flds2 As outlook.Folders
Dim idx As Integer
Dim myItem As outlook.MailItem
Set nsp = outApp.GetNamespace("MAPI")
Set mpf = nsp.GetDefaultFolder(olFolderInbox)
Set flds = mpf.Folders
Set mpfSubFolder = flds.GetFirst

Dim myNewFolder As outlook.MAPIFolder

Do While Not mpfSubFolder Is Nothing  'client name
    Debug.Print mpfSubFolder.Name
    Set myNewFolder = mpfSubFolder
    For i = 1 To myNewFolder.Folders.count  'debt
        Debug.Print myNewFolder.Folders.Item(i) '.Items(1)
          If myNewFolder.Folders.Item(i).Folders.count = 0 Then
            For A = 1 To myNewFolder.Folders.Item(i).Folders.count 'client
                     ' Debug.Print myNewFolder.Folders.Item(i) 'debt
                     Set myFolder = myNewFolder.Folders.Item(i).Folders.Item(A) 'open trades
                        Debug.Print myNewFolder.Folders.Item(i).Folders.Item(A)
                        Debug.Print myNewFolder.Folders.Item(i).Folders.Item(A).Items.count
                        For x = 1 To myNewFolder.Folders.Item(i).Folders.Item(A).Items.count
                           Debug.Print myNewFolder.Folders.Item(i).Folders.Item(A).Items(x)
                               Set myItem = myNewFolder.Folders.Item(i).Folders.Item(A).Items(x)
'>>>>>>>>never getting in here
                                MsgBox "never getting to this point even when there are subfolders"
                    Next x
                Next A
               End If 'SUBFOLDER COUNT =0
          Next i
        Set mpfSubFolder = flds.GetNext

Exit Sub
End Sub
Question by:dleads
LVL 44

Expert Comment

ID: 20389409
LVL 19

Expert Comment

ID: 20389436
see if this does what you want
Sub superduper()

Dim objFolder As Outlook.MAPIFolder

Dim outApp As New Outlook.Application

Dim nsp As Outlook.NameSpace

Dim mpf As Outlook.MAPIFolder

Dim myItem As Outlook.MailItem

Set nsp = outApp.GetNamespace("MAPI")

Set mpf = nsp.GetDefaultFolder(olFolderInbox)

Set objFolder = OutlookFolderNames(mpf, "somefolder")

End Sub

Public Function OutlookFolderNames(objFolder As Outlook.MAPIFolder, strFolderName As String) As Object


'searches recursively through folders until it finds the one you have listed

'just don't list one that exists and it will search them all

    On Error GoTo ErrorHandler

    Dim objOneSubFolder As Outlook.MAPIFolder

    If Not objFolder Is Nothing Then

        If LCase(strFolderName) = LCase(objFolder.Name) Then

            Set OutlookFolderNames = objFolder


            ' Check if folders collection is not empty

            If objFolder.Folders.Count > 0 And _

                   Not objFolder.Folders Is Nothing Then

                For Each oFolder In objFolder.Folders

                    Set objOneSubFolder = oFolder

                    ' only check mail item folder

                    If objOneSubFolder.DefaultItemType _

                         = olMailItem Then

                        If LCase(strFolderName) = _

                          LCase(objOneSubFolder.Name) Then

                            Set OutlookFolderNames = _


                            Exit For


                            If objOneSubFolder.Folders.Count _

                                > 0 Then

                                MsgBox "hi"

                                Set OutlookFolderNames = _

                                  OutlookFolderNames _

                                (objOneSubFolder, strFolderName)

                            End If

                        End If

                    End If


            End If

        End If

    End If

    Exit Function


    Set OutlookFolderNames = Nothing

End Function

Open in new window

LVL 59

Accepted Solution

Chris Bottomley earned 500 total points
ID: 20389530
To recursively pass through all outlook folders you could try the following, I appreciate it doesn't follow your own code but I have used it successfully elsewhere:


Sub launchpad()


Dim olApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Dim MyFolder As Outlook.MAPIFolder

    On Error Resume Next


    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set MyFolder = objNS.PickFolder

    Call ProcessFolder(MyFolder)

    Set objNS = Nothing


Set MyFolder = Nothing

Set olApp = Nothing

Set objNS = Nothing

End Sub



Sub ProcessFolder(StartFolder As MAPIFolder)

Dim objFolder As Outlook.MAPIFolder

Dim objItem As Object

Dim mai As mailitem

    On Error Resume Next

'    MsgBox StartFolder.Path, , "testing"


    ' process all the items in this folder

'    For Each objItem In StartFolder.Items

'        If TypeName(objItem) = "MailItem" Then

'            Set mai = objItem

'        End If

'    Next


    ' process all the subfolders of this folder

    For Each objFolder In StartFolder.Folders

        Call ProcessFolder(objFolder)



Set mai = Nothing

Set objFolder = Nothing

Set objItem = Nothing

End Sub

Open in new window


Author Closing Comment

ID: 31427379
Wellio, unfortuantely, your code does not go into the level that I need.  It happens to get to the same level as my posted code.

chris_bottomley's code best suited my needs.  

Thank you all.

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

920 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now