dleads
asked on
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(olFol derInbox)
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).It ems.count
For x = 1 To myNewFolder.Folders.Item(i ).Folders. Item(A).It ems.count
Debug.Print myNewFolder.Folders.Item(i ).Folders. Item(A).It ems(x)
Set myItem = myNewFolder.Folders.Item(i ).Folders. Item(A).It ems(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
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(olFol
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
If myNewFolder.Folders.Item(i
Else
For A = 1 To myNewFolder.Folders.Item(i
' Debug.Print myNewFolder.Folders.Item(i
Set myFolder = myNewFolder.Folders.Item(i
Debug.Print myNewFolder.Folders.Item(i
Debug.Print myNewFolder.Folders.Item(i
For x = 1 To myNewFolder.Folders.Item(i
Debug.Print myNewFolder.Folders.Item(i
Set myItem = myNewFolder.Folders.Item(i
'>>>>>>>>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
You may find this helpful: http://www.xtremevbtalk.com/archive/index.php/t-224290.html
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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.
chris_bottomley's code best suited my needs.
Thank you all.