请按照以下步骤将Outlook文件夹结构复制到桌面或Windows资源管理器。

1.在导航窗格上，请单击以突出显示要复制其文件夹结构的指定文件夹，然后按 其他 + F11 键以打开“ Microsoft Visual Basic应用程序”窗口。

2。 点击 工具 > 参考资料 打开引用对话框。 然后在对话框中检查 Microsoft脚本运行时 选项，然后单击 OK 按钮。 看截图：

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.在弹出的浏览文件夹对话框中，请选择指定的文件夹，然后放置复制的文件夹结构，然后单击 OK 按钮。 看截图：

现在转到指定的文件夹，您将看到文件夹结构已复制到指定的硬盘。 看截图：

备注：文件夹项目（例如电子邮件，约会，任务等）也被复制到硬盘中的相应文件夹中。

如何在Outlook中将文件夹结构复制到新的PST数据文件？