Solved

Loop Through Outlook Folders using vba

Posted on 2007-12-01
4
19,956 Views
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
         
          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
Comment
Question by:dleads
4 Comments
 
LVL 44

Expert Comment

by:GRayL
ID: 20389409
0
 
LVL 19

Expert Comment

by:weellio
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
        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
 
LVL 59

Accepted Solution

by:
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:

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
 

Author Closing Comment

by:dleads
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.
0

Featured Post

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

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

Find out what you should include to make the best professional email signature for your organization.
Read this checklist to learn more about the 15 things you should never include in an email signature.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

776 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