Vui lòng làm theo các bước dưới đây để sao chép cấu trúc thư mục Outlook vào màn hình nền hoặc trình khám phá cửa sổ.

1. Trên Ngăn Dẫn hướng, vui lòng nhấp để đánh dấu thư mục được chỉ định có cấu trúc thư mục mà bạn sẽ sao chép, và nhấn Khác + F11 để mở cửa sổ Microsoft Visual Basic for Applications.

2. nhấp chuột CÔNG CỤ > dự án để mở hộp thoại Tham chiếu. Sau đó, trong hộp thoại, chọn Thời gian chạy tập lệnh của Microsoft và nhấp vào OK cái nút. Xem ảnh chụp màn hình:

3. nhấp chuột Chèn > Mô-đunvà sao chép và dán mã VBA bên dưới vào cửa sổ mô-đun mới.

VBA: Sao chép cấu trúc thư mục Outlook sang windows explorer

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. nhấn F5 phím hoặc nhấp vào chạy để chạy VBA này.

5. Trong hộp thoại Browse For Folder bật ra, vui lòng chọn thư mục được chỉ định mà bạn sẽ đặt cấu trúc thư mục đã sao chép và nhấp vào OK cái nút. Xem ảnh chụp màn hình:

Bây giờ vào thư mục được chỉ định, bạn sẽ thấy cấu trúc thư mục được sao chép vào đĩa cứng được chỉ định. Xem ảnh chụp màn hình:

Chú thích: các mục thư mục, chẳng hạn như email, cuộc hẹn, nhiệm vụ, v.v. cũng được sao chép vào các thư mục tương ứng trong đĩa cứng.

Làm cách nào để sao chép cấu trúc thư mục sang tệp dữ liệu pst mới trong Outlook?