如何將 Outlook 資料夾結構複製到桌面（Windows 檔案總管）？

眾所周知，我們可利用「封存」功能將資料夾結構複製到另一個 Outlook 帳戶，但您知道如何將 Outlook 資料夾結構複製到特定位置（例如桌面）嗎？本文將介紹一段 VBA 程式碼，助您輕鬆將 Outlook 資料夾結構匯出至 Windows 檔案總管。

將 Outlook 資料夾結構複製到桌面（Windows 檔案總管）

---

將 Outlook 資料夾結構複製到桌面（Windows 檔案總管）

請依照下列步驟，將 Outlook 資料夾結構複製到桌面或 Windows 檔案總管中。

1. 在導航窗格中，請先點選您欲複製資料夾結構的目標資料夾，再按下「Alt」+「F11」鍵，即可開啟 Microsoft Visual Basic for Applications 視窗。

2. 按一下「工具」>「參考設定」，開啟「參考設定」對話方塊後，勾選「Microsoft Scripting Runtime」選項，再按一下「確定」按鈕。請參閱截圖：

3. 點選「插入」>「模組」，並將下方的 VBA 程式碼複製貼上至新開啟的模組視窗中。

VBA：將 Outlook 資料夾結構複製到 Windows 檔案總管

Dim xFSO As Scripting.FileSystemObject
Sub CopyOutlookFldStructureToWinExplorer()
    ExportAction "Copy"
End Sub
  
Sub ExportAction(xAction As String)
Dim xFolder As Outlook.Folder
Dim xFldPath As String
xFldPath = SelectAFolder()
If xFldPath = "" Then
    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
Else
    Set xFSO = New Scripting.FileSystemObject
    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
    ExportOutlookFolder xFolder, xFldPath
End If
Set xFolder = Nothing
Set xFSO = Nothing
End Sub

Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xPath As String
Dim xFilePath As String
Dim xSubject As String
Dim xCount As Integer
Dim xFilename As String
On Error Resume Next
xPath = xFldPath & "\" & OutlookFolder.Name
'?????????,??????
If Dir(xPath, 16) = Empty Then MkDir xPath
For Each xItem In OutlookFolder.Items
    xSubject = ReplaceInvalidCharacters(xItem.Subject)
    xFilename = xSubject & ".msg"
    xCount = 0
    xFilePath = xPath & "\" & xFilename
    If xFSO.FileExists(xFilePath) Then
        xCount = xCount + 1
        xFilename = xSubject & " (" & xCount & ").msg"
        xFilePath = xPath & "\" & xFilename
    End If
    xItem.SaveAs xFilePath, olMSG
Next
For Each xSubFld In OutlookFolder.Folders
    ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub

Function SelectAFolder() As String
Dim xSelFolder As Object
Dim xShell As Object
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
If Not TypeName(xSelFolder) = "Nothing" Then
    SelectAFolder = xSelFolder.self.Path
End If
Set xSelFolder = Nothing
Set xShell = Nothing
End Function
  
Function ReplaceInvalidCharacters(Str As String) As String
Dim xRegEx
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
ReplaceInvalidCharacters = xRegEx.Replace(Str, "")
End Function

4. 按下「F5」鍵或點擊「執行」按鈕，即可執行此 VBA。

5. 在彈出的「瀏覽資料夾」對話方塊中，請選取您要存放已複製資料夾結構的目標資料夾，然後點擊「確定」按鈕。請參閱截圖：

現在前往指定的資料夾，您將看到資料夾結構已完整複製至指定的硬碟位置。請參閱截圖：

注意：資料夾中的項目（例如電子郵件、約會、工作等）將一併複製至硬碟中對應的資料夾內。

---

相關文章

如何在 Outlook 中將資料夾結構複製到新的 PST 檔案？