Outlook folder navigation

I have for a while used a common function for navigating to a folder.  The overhead of the function for me is a worthy tradeoff for the simplicity in navigating to a folder.  The normal version I have used creates any 'missing' folders as it goes.  This version has an optional parameter to allow checking for a folder if required ... but defaults to creating the folder(s).  It is based off an unattributed script I started using and I have used it in all MS applications and with minor alterations in VB Scripts.

The function is tolerant of forward or backslash and preceding or trailing 'slashes'.

Sample Usage:

1. Check for Folder

olnav2folder("\\Personal Folders\search foldersz\Unread or For Follow Up", True) is nothing ... Returns true or false depending on if the folder path exists

2. Check for Folder

olnav2folder("\\Personal Folders\search foldersz\Unread or For Follow Up") is nothing ... Returns true since it will create the folder irrespective

3. Get a Folder reference

Set fldr = olNav2Folder("\\Personal Folders\Inbox\Experts Exchange") ... WIll return a reference to the outlook folder, (i.e. Debug.Print fldr.Items.Count)

4. Using a Folder reference to access folder properties

olNav2Folder("Personal Folders\Inbox/Experts Exchange\").Items.Count

Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As object
                      Dim olApp As Object
                      Dim olNS As Object
                      Dim olfldr As Object
                      Dim reqdFolder As Object
                      Dim arrFolders() As String
                      Dim nestCount As Integer
                       
                          On Error Resume Next
                          foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
                          If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
                          arrFolders() = Split(foldername, "\")
                          Set olApp = Outlook.Application
                          Set olNS = olApp.GetNamespace("MAPI")
                          Set reqdFolder = olNS.folders.Item(arrFolders(0))
                          For nestCount = 1 To UBound(arrFolders)
                              If Not reqdFolder Is Nothing Then
                                  Set olfldr = reqdFolder.folders
                                  Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                                  If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                                      If CheckOnly Then
                                          Set reqdFolder = Nothing
                                          Exit For
                                      Else
                                          reqdFolder.folders.Add (arrFolders(nestCount))
                                          Set olfldr = reqdFolder.folders
                                          Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                                      End If
                                  End If
                              Else
                              End If
                          Next
                          Set olNav2Folder = reqdFolder
                          Set olApp = Nothing
                          Set olNS = Nothing
                          Set olfldr = Nothing
                          Set reqdFolder = Nothing
                      End Function

Select all Open in new window