Copy Outlook Emails and Folder Structure to Folder (Public)


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

Saved by @cnewnham #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" 


    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 


For Each xSubFld In OutlookFolder.Folders 

    ExportOutlookFolder xSubFld, xPath 


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