Loop Through Outlook Folders using vba

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
Who is Participating?
Chris BottomleyConnect With a Mentor Commented:
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

William ElliottSr Tech GuruCommented:
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

dleadsAuthor Commented:
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.
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.