自定义Outlook 2010导航窗格

我想为Outlook创建自定义导航窗格。我的当前设置（请参阅图像）适用于将单个电子邮件拖放到相应的文件夹。 NB我使用的是Outlook 2010自定义Outlook 2010导航窗格

目前我已经在快速访问工具栏按钮运行于OpenFolders VBA子，瓦大家都出去了（或关闭它们）

但最好我想他们都在一个单个窗口。

此外，我不知道如何打开所有可见文件夹 - 在我的情况下，这意味着约。 3列文件夹名称（这不会改变太多，所以可以硬编码）。理想情况下会剪裁名称以减少屏幕宽度。

最终，这个单独的'导航窗格'在每个文件夹名称的RHS上也会有一个小按钮，它会自动移动阅读窗格中的电子邮件并选择下一封电子邮件（而不是拖放）。

这是我目前简单的代码（NB GetFolderPath返回从路径上的收件箱下面的相关文件夹的引用）

Global myEmailRoot 
Global lastOFTime 

Sub OpenFolders() 
    myEmailRoot = "[email protected]\Inbox\" 

    'Single Clicking the OpenFolders button will open the windows, or if already open then retile them in order 
    'Double Clicking the OpenFolders button in the Quick Access Toolbar will close the windows 

    If sortIfFolderWindowsExist Then 
     If Timer() - lastOFTime < 5 Then 
      closeFolderWindows 
     End If 
     Exit Sub 
    End If 

    lastOFTime = Timer() 

    Dim oFolder As Outlook.Folder 

    Set oFolder = GetFolderPath("CCG") 
    oFolder.Display 
    resizeWin (0) 

    Set oFolder = GetFolderPath("Mental Health") 
    oFolder.Display 
    resizeWin (1) 

    Set oFolder = GetFolderPath("Personal") 
    oFolder.Display 
    resizeWin (2) 

    Set oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
    oFolder.Display 
    resizeWin (3) 

End Sub 

Sub resizeWin(col) 
    Outlook.Application.ActiveExplorer.Left = col * 150 
    Outlook.Application.ActiveExplorer.Top = 0 
    Outlook.Application.ActiveExplorer.Width = 1920 - (col * 150) 
    Outlook.Application.ActiveExplorer.Height = 1024 
End Sub 

Function sortIfFolderWindowsExist() 
    ' resort windows (if they exist) so layering is correct 
    i = 1 
    curColPix = 0 
    While i > 0 
     For i = Explorers.Count To 0 Step -1 
      If Explorers(i).Left = curColPix Then 
       Explorers(i).Activate 
       Exit For 
      End If 
     Next 
     curColPix = curColPix + 150 
     If curColPix > 450 Then 
      sortIfFolderWindowsExist = True 
      Exit Function 
     End If 
    Wend 
End Function 

Function closeFolderWindows() 
    ' resort windows (if they exist) so layering is correct 
    i = 1 
    curColPix = 450 
    maxWin = 0 
    minWin = 9999 
    While i > 0 
     For i = Explorers.Count To 1 Step -1 
      If Explorers(i).Left = curColPix Then 
       If i > maxWin Then maxWin = i 
       If i < minWin Then minWin = i 
       correctWins = correctWins + 1 
       Explorers(i).Activate 
       If maxWin - minWin = 3 Then 
        For j = 1 To 4 
         Explorers(minWin).Close 
        Next 
        Exit Function 
       End If 
       Exit For 
      End If 
     Next 
     curColPix = curColPix - 150 
    Wend 
End Function 

Function GetFolderPath(ByVal folderPath As String) As Outlook.Folder 
    Dim oFolder As Outlook.Folder 
    Dim FoldersArray As Variant 
    Dim i As Integer 

    On Error GoTo GetFolderPath_Error 
    If Left(folderPath, 2) = "\\" Then 
     folderPath = Right(folderPath, Len(folderPath) - 2) 
    Else 
     folderPath = myEmailRoot & folderPath 
    End If 

    'Convert folderpath to array 
    FoldersArray = Split(folderPath, "\") 
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) 
    If Not oFolder Is Nothing Then 
     For i = 1 To UBound(FoldersArray, 1) 
      Dim SubFolders As Outlook.Folders 
      Set SubFolders = oFolder.Folders 
      Set oFolder = SubFolders.Item(FoldersArray(i)) 
      If oFolder Is Nothing Then 
       Set GetFolderPath = Nothing 
      End If 
     Next 
    End If 
    'Return the oFolder 
    Set GetFolderPath = oFolder 
    Exit Function 

GetFolderPath_Error: 
    Set GetFolderPath = Nothing 
    Exit Function 
End Function