Copy Outlook Emails and Folder Structure to Folder (Public)

PHOTO EMBED

Thu Aug 05 2021 22:57:27 GMT+0000 (UTC)

Saved by @Darkleech #vba

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 
content_copyCOPY