Sub Macro1()
frmFolders.Show
End Sub

Private Sub lstFolders_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim olFldr As Folder
Dim vFolder As Variant
Dim i As Integer
    Set olFldr = Session.GetDefaultFolder(olFolderInbox).Parent
    vFolder = Split(lstFolders.Text, "\")
    For i = 0 To UBound(vFolder)
        Set olFldr = olFldr.folders(vFolder(i))
    Next i
    Hide
    olFldr.Display
lbl_Exit:
    Set olFldr = Nothing
    Unload Me
    Exit Sub
End Sub


Private Sub CommandOK_Click()
Dim olFldr As Folder
Dim vFolder As Variant
Dim i As Integer
    If lstFolders.ListIndex > -1 Then
        Set olFldr = Session.GetDefaultFolder(olFolderInbox).Parent
        vFolder = Split(lstFolders.Text, "\")
        For i = 0 To UBound(vFolder)
            Set olFldr = olFldr.folders(vFolder(i))
        Next i
        Hide
        olFldr.Display
    Else
        Beep
        MsgBox "Nothing selected"
    End If
lbl_Exit:
    Set olFldr = Nothing
    Unload Me
    Exit Sub
End Sub

Private Sub ResetList(X As String)
Dim cFolders As Collection
Dim olfolder As Outlook.Folder
Dim SubFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace
Dim strPath As String
Dim sSubPath As String
Dim sStore As String
    lstFolders.Clear
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.GetDefaultFolder(olFolderInbox).Parent
    Do While cFolders.Count > 0
        Set olfolder = cFolders(1)
        cFolders.Remove 1
        sStore = olfolder.Store
        sSubPath = Replace(olfolder.FolderPath, "\\" & sStore & "\", strPath)

        ProcessFolder olfolder, sSubPath, X
        If olfolder.folders.Count > 0 Then
            For Each SubFolder In olfolder.folders
                cFolders.Add SubFolder
            Next SubFolder
        End If
    Loop
lbl_Exit:
    Set olfolder = Nothing
    Set SubFolder = Nothing
    Set cFolders = Nothing
    Exit Sub
 End Sub