Sort the folders collection in outlook

Hi all,
I was wondering if is it possible to process all folders and subfolders in a namespace alphabetically.
the loop below opens all pst files, and prints all folder names to the immediate window, but the list is random.
And, of course, if it is possilbe, please show me how.
Regards,
Ozzy
Sub Caller()
 
    Dim sfld As Outlook.MAPIFolder
 
    If myolapp Is Nothing Then
        Set oa = Application
    Else
        Set oa = myolapp
    End If
    
    If mynamespace Is Nothing Then
        Set ns = oa.GetNamespace("MAPI")
    Else
        Set ns = mynamespace
    End If
    
    For Each sfld In ns.Folders
        Call RunOnFolder(sfld)
    Next
 
End Sub
 
 
Sub RunOnFolder(fld As Outlook.MAPIFolder)
    Dim sfld As Outlook.MAPIFolder
        
    Debug.Print fld.FolderPath
    
    For Each sfld In fld.Folders
        Call RunOnFolder(sfld)
    Next
End Sub

Open in new window

OzzymandiasAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

David LeeCommented:
Hi, Ozzymandias.

That's possible.  The SortDictionary function is not mine.  It is a modified version of the code in this Microsoft KB article:  http://support.microsoft.com/kb/246067
Dim objDict As Object
 
Sub Caller()
    Dim sfld As Outlook.MAPIFolder, objSortedDict As Object, arrItems As Variant, varItem As Variant
    
    Set objDict = CreateObject("Scripting.Dictionary")
       
    For Each sfld In Outlook.Application.Session.Folders
        Call RunOnFolder(sfld)
    Next
    Set objSortedDict = SortDictionary(objDict, 1)
    arrItems = objSortedDict.Items
    For Each varItem In arrItems
        Debug.Print varItem
    Next
End Sub
 
Sub RunOnFolder(fld As Outlook.MAPIFolder)
    Dim sfld As Outlook.MAPIFolder
        
    objDict.Add fld.FolderPath, fld.FolderPath
    DoEvents
    For Each sfld In fld.Folders
        Call RunOnFolder(sfld)
    Next
End Sub
 
  ' Description:
  '   Sorts a dictionary by either key or item
  ' Parameters:
  '   objDict - the dictionary to sort
  '   intSort - the field to sort (1=key, 2=item)
  ' Returns:
  '   A dictionary sorted by intSort
  '
  Function SortDictionary(ByVal objDict, ByVal intSort) As Object
 
 
    ' declare constants
    Const dictKey = 1
    Const dictItem = 2
 
 
    ' declare our variables
    Dim strDict()
    Dim objKey
    Dim strKey, strItem
    Dim x, y, z
 
 
    ' get the dictionary count
    z = objDict.Count
 
 
    ' we need more than one item to warrant sorting
    If z > 1 Then
      ' create an array to store dictionary information
      ReDim strDict(z, 2)
      x = 0
      ' populate the string array
      For Each objKey In objDict
          strDict(x, dictKey) = CStr(objKey)
          strDict(x, dictItem) = CStr(objDict(objKey))
          x = x + 1
      Next
 
 
      ' perform a a shell sort of the string array
      For x = 0 To (z - 2)
        For y = x To (z - 1)
          If StrComp(strDict(x, intSort), strDict(y, intSort), vbTextCompare) > 0 Then
              strKey = strDict(x, dictKey)
              strItem = strDict(x, dictItem)
              strDict(x, dictKey) = strDict(y, dictKey)
              strDict(x, dictItem) = strDict(y, dictItem)
              strDict(y, dictKey) = strKey
              strDict(y, dictItem) = strItem
          End If
        Next
      Next
 
 
      ' erase the contents of the dictionary object
      objDict.RemoveAll
 
 
      ' repopulate the dictionary with the sorted information
      For x = 0 To (z - 1)
        objDict.Add strDict(x, dictKey), strDict(x, dictItem)
      Next
 
 
    End If
 
    Set SortDictionary = objDict
  End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
OzzymandiasAuthor Commented:
Thank you!  That seems to do the trick.

sorry for the late reply
0
David LeeCommented:
No problem.  You're welcome.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Programming

From novice to tech pro — start learning today.