自定義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