• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 20962
  • Last Modified:

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
         
          Else
            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
    Loop

Exit Sub
End Sub
0
dleads
Asked:
dleads
1 Solution
 
GRayLCommented:
0
 
weellioCommented:
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
        Else
            ' 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 = _
                                   objOneSubFolder
                            Exit For
                        Else
                            If objOneSubFolder.Folders.Count _
                                > 0 Then
                                MsgBox "hi"
                                Set OutlookFolderNames = _
                                  OutlookFolderNames _
                                (objOneSubFolder, strFolderName)
                            End If
                        End If
                    End If
                Next
            End If
        End If
    End If
 
    Exit Function
 
ErrorHandler:
    Set OutlookFolderNames = Nothing
End Function

Open in new window

0
 
Chris BottomleyCommented:
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:

Chris


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)
    Next
 
Set mai = Nothing
Set objFolder = Nothing
Set objItem = Nothing
End Sub

Open in new window

0
 
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.
0

Featured Post

Restore individual SQL databases with ease

Veeam Explorer for Microsoft SQL Server delivers an easy-to-use, wizard-driven interface for restoring your databases from a backup. No expert SQL background required. Web interface provides a complete view of all available SQL databases to simplify the recovery of lost database

Tackle projects and never again get stuck behind a technical roadblock.
Join Now