Select Outlook folder using path

Question

I have a vast number of folders in my Outlook inbox. I have a macro which will list (in a listbox object) all the folders that have xxxx text in it.

I then manually drill down into the folder heirarchy to select the folder. It is very time consuming given the number of levels of folders I have.

How do I take the text path from my list box entry, and with a double-click, select the folder?

Here's an example path (redacted):

\\john.smith@somemailbox.biz\Inbox\04_Projects\Florida\Data Migration\01_Data Cleansing & Testing

Sub MainProc()
    'On Error GoTo On_Error
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Folders As Outlook.Folders
    Dim Folder As Outlook.Folder
    Dim reply As Integer
    Dim NumFolders As Integer

    Set Session = Application.Session
    Set Folders = Session.Folders
    ArrayElem = 0
    BugOut = False
    '----------------
    RowCount = 0
    '----------------
    ReDim FoldArray(1)
    FSearch = InputBox("Enter search text", "Find folders")
    'MySearch = "Test21"
    'MySearch = InputBox("Type in a folder name", "Folder Search")
    '----------------------------------------------------------
    ' There is only one folder we need  in the "Folders" collection
     ' and this is actually the mailbox 
    '----------------------------------------------------------
    For Each Folder In Folders
        If Folder.Name = "john.smith@somemailbox.biz" Then
            Call Subsid(Folder)
       End If
    Next
    'For i = LBound(MyArray) To UBound(MyArray)
    '   msg = msg & MyArray(i) & vbNewLine
    'Next i
    'MsgBox msg
    'MsgBox RowCount
    If RowCount <> 0 Then
        FindMyForm.TextBox1.BackColor = RGB(204, 255, 204)
        FindMyForm.TextBox1.Value = "Here are the folders that contain '" & 
    FSearch & "'"
       Else
        FindMyForm.TextBox1.BackColor = RGB(255, 204, 204)
        FindMyForm.TextBox1.Value = "I'm afraid there are no folders that 
contain '" & FSearch & "'"
    End If
    FindMyForm.ListBox1.List = FoldArray
    FindMyForm.StartUpPosition = 2
    FindMyForm.Show
 
Exiting:
        Set Session = Nothing
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub

Subsid code:

Private Sub SubSid(CurrentFolder As Outlook.Folder)
    Dim SubFolders As Outlook.Folders
    Dim SubFolder As Outlook.Folder

    Set SubFolders = CurrentFolder.Folders
    For Each SubFolder In CurrentFolder.Folders
        'SubFolder.Display
        If SubFolder.Name = "Inbox" Then
            Call ArrayProc(SubFolder)
        End If
    Next SubFolder

End Sub

Array Population:

Private Sub ArrayProc(CurrentFolder As Outlook.Folder)
    Dim SubFolders As Outlook.Folders
    Dim SubFolder As Outlook.Folder
    Dim StayAtLevel As Boolean
    Dim SubString As String
    Dim NewString As String

    '---------------------------------------------
    ' We are now at the "INBOX" level of folders
    '---------------------------------------------
    Set SubFolders = CurrentFolder.Folders
    'MsgBox CurrentFolder.FolderPath
        For Each SubFolder In SubFolders
        If InStr(1, SubFolder.Name, FSearch) Then
            ReDim Preserve FoldArray(UBound(FoldArray) + 1)
            SubString = SubFolder.FolderPath
            NewString = Replace(SubString, "\\John.smith@somemailbox.biz\", "")
            FoldArray(ArrayElem) = NewString
            ArrayElem = ArrayElem + 1
            RowCount = RowCount + 1
            End If
          Call ArrayProc(SubFolder)
    Next SubFolder 
End Sub