Solved

Loop Through Outlook Folders using vba

Posted on 2007-12-01
4
19,726 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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
If you don't know how to downgrade, my instructions below should be helpful.
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.
In Microsoft Access, learn the trick to repeating sub-report headings at the top of each page. The problem with sub-reports and headings: Add a dummy group to the sub report using the expression =1: Set the “Repeat Section” property of the dummy…

759 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

20 Experts available now in Live!

Get 1:1 Help Now