Export Outlook Folders to the File System

 

I stumbled across a question on Experts-Exchange asking if there’s a way to copy/move an Outlook folder to a folder in the file system. The author would like to drag-and-drop the Outlook folder to the file system folder, but notes that while Outlook allows you to drag a message from Outlook to the file system it does not allow you to do the same with a folder. While I’m not aware of any way to do this via dragging and dropping, it’s easy enough to script a solution that allows a user to select a folder and have it copied/moved to the file system. Here’s my solution.

Using this solution the user starts by selecting an Outlook folder, then run one of two macros: one that copies the folder to the file system, or one that moves it to the file system (copies and then deletes the Outlook folder). Once triggered, the code begins by prompting the user for the file system folder to export to. If the user selects a folder, then the code creates a new folder under the target folder and gives it the same name as the Outlook folder. Next, the code copies the contents of the Outlook folder to the new file system folder, saving each item in .msg format. Finally, if the user selected to move the Outlook folder, then the code deletes the selected folder from Outlook. The solution also handles multiple levels of folders. If a folder has sub-folders, then the code copies/moves them to the file system too. If the user opts to move a folder with sub-folders, then the code deletes them too when it deletes the parent folder. Please keep that in mind.

Instructions.

Follow these instructions to add the code to Outlook.

1. Start Outlook
2. Press ALT + F11 to open the Visual Basic Editor
3. If not already expanded, expand Microsoft Office Outlook Objects
4. If not already expanded, expand Modules
5. Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert → Module.
6. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
7. Click the diskette icon on the toolbar to save the changes
8. Close the VB Editor

'On the next line edit the starting folder as desired.  If you leave it blank, then the starting folder will be the local computer.
Const STARTING_FOLDER = ""
 
Dim objFSO As Object
 
Sub CopyOutlookFolderToFileSystem()
    ExportController "Copy"
End Sub
 
Sub MoveOutlookFolderToFileSystem()
    ExportController "Move"
End Sub
 
Sub ExportController(strAction As String)
    Dim olkFld As Outlook.MAPIFolder, strPath As String
    strPath = SelectFolder(STARTING_FOLDER)
    If strPath = "" Then
        MsgBox "You did not select a folder.  Export cancelled.", vbInformation + vbOKOnly, "Export Outlook Folder"
    Else
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set olkFld = Application.ActiveExplorer.CurrentFolder
        ExportOutlookFolder olkFld, strPath
        If LCase(strAction) = "move" Then olkFld.Delete
    End If
    Set olkFld = Nothing
    Set objFSO = Nothing
End Sub
 
Sub ExportOutlookFolder(ByVal olkFld As Outlook.MAPIFolder, strStartingPath As String)
    Dim olkSub As Outlook.MAPIFolder, olkItm As Object, strPath As String, strMyPath As String, strSubejct As String, intCount As Integer
    strPath = strStartingPath & "\" & olkFld.Name
    objFSO.CreateFolder strPath
    For Each olkItm In olkFld.Items
        strSubject = RemoveIllegalCharacters(olkItm.Subject)
        strFilename = strSubject & ".msg"
        intCount = 0
        Do While True
            strMyPath = strPath & "\" & strFilename
            If objFSO.FileExists(strMyPath) Then
                intCount = intCount + 1
                strFilename = strSubject & " (" & intCount & ").msg"
            Else
                Exit Do
            End If
        Loop
        olkItm.SaveAs strMyPath, olMSG
    Next
    For Each olkSub In olkFld.Folders
        ExportOutlookFolder olkSub, strPath
    Next
    Set olkFld = Nothing
    Set olkItm = Nothing
End Sub
 
Function SelectFolder(varStartingFolder As Variant) As String
    ' This function is a modified version of the SelectFolder function written by Rob van der Woude (http://www.robvanderwoude.com/vbstech_ui_selectfolder.php)
 
    ' Standard housekeeping
    Dim objFolder As Object, objShell As Object
     
    ' Custom error handling
    On Error Resume Next
 
    ' Create a dialog object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select the folder you want to export to", 0, varStartingFolder)
 
    ' Return the path of the selected folder
    If TypeName(objFolder) <> "Nothing" Then SelectFolder = objFolder.self.Path
 
    ' Standard housekeeping
    Set objFolder = Nothing
    Set objShell = Nothing
    On Error GoTo 0
End Function
 
Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "") End Function 

Using the Code.

1. Select an Outlook folder.
2. Run either the CopyOutlookFolderToFileSystem or the MoveOutlookFolderToFileSystem macro depending on whether you want to copy/move the folder to the file system.

Adding Buttons to Run the Macro with a Single Click

If you want to run the macro with a single click, then you’ll need to add toolbar buttons for each macro in Outlook 2007 or buttons on the Quick Access Toolbar (QAT) for Outlook 2010.

Outlook 2007. Follow these instructions to add toolbar buttons that runs each macro.

Outlook 2010. Follow these instructions to add the macros to the QAT.

Revisions.

Revision 1.

A reader named Chris Robinson suggested a couple of changes, which this revision implements. Specifically, Chris suggested changing

• The file date/time to match that of the original message instead of using the date/time the message was exported.
• The file name to include the sender’s name

Using this version the file name format is now

[From] Sender’s Name [Subject] Subject of the Message

'On the next line edit the starting folder as desired.  If you leave it blank, then the starting folder will be the local computer.
Const STARTING_FOLDER = ""
 
Dim objFSO As Object
 
Sub CopyOutlookFolderToFileSystem()
    ExportController "Copy"
End Sub
 
Sub MoveOutlookFolderToFileSystem()
    ExportController "Move"
End Sub
 
Sub ExportController(strAction As String)
    Dim olkFld As Outlook.MAPIFolder, strPath As String
    strPath = SelectFolder(STARTING_FOLDER)
    If strPath = "" Then
        MsgBox "You did not select a folder.  Export cancelled.", vbInformation + vbOKOnly, "Export Outlook Folder"
    Else
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set olkFld = Application.ActiveExplorer.CurrentFolder
        ExportOutlookFolder olkFld, strPath
        If LCase(strAction) = "move" Then olkFld.Delete
    End If
    Set olkFld = Nothing
    Set objFSO = Nothing
End Sub
 
Sub ExportOutlookFolder(ByVal olkFld As Outlook.MAPIFolder, strStartingPath As String)
    Dim olkSub As Outlook.MAPIFolder, olkItm As Object, strPath As String, strMyPath As String, strSubejct As String, intCount As Integer
    strPath = strStartingPath & "\" & olkFld.Name
    objFSO.CreateFolder strPath
    For Each olkItm In olkFld.Items
        strSubject = "[From] " & olkItm.SenderName & " [Subject] " & RemoveIllegalCharacters(olkItm.Subject)
        strFilename = strSubject & ".msg"
        intCount = 0
        Do While True
            strMyPath = strPath & "\" & strFilename
            If objFSO.FileExists(strMyPath) Then
                intCount = intCount + 1
                strFilename = strSubject & " (" & intCount & ").msg"
            Else
                Exit Do
            End If
        Loop
        olkItm.SaveAs strMyPath, olMSG
        ChangeTimeStamp strMyPath, olkItm.ReceivedTime
    Next
    For Each olkSub In olkFld.Folders
        ExportOutlookFolder olkSub, strPath
    Next
    Set olkFld = Nothing
    Set olkItm = Nothing
End Sub
 
Function SelectFolder(varStartingFolder As Variant) As String
    ' This function is a modified version of the SelectFolder function written by Rob van der Woude (http://www.robvanderwoude.com/vbstech_ui_selectfolder.php)
 
    ' Standard housekeeping
    Dim objFolder As Object, objShell As Object
     
    ' Custom error handling
    On Error Resume Next
 
    ' Create a dialog object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select the folder you want to export to", 0, varStartingFolder)
 
    ' Return the path of the selected folder
    If TypeName(objFolder) <> "Nothing" Then SelectFolder = objFolder.self.Path
 
    ' Standard housekeeping
    Set objFolder = Nothing
    Set objShell = Nothing
    On Error GoTo 0
End Function
 
Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub ChangeTimeStamp(strFile As String, datStamp As Date)
    Dim objShell As Object, objFolder As Object, objFolderItem As Object, varPath As Variant, varName As Variant
    varName = Mid(strFile, InStrRev(strFile, "\") + 1)
    varPath = Mid(strFile, 1, InStrRev(strFile, "\"))
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.NameSpace(varPath)
    Set objFolderItem = objFolder.ParseName(varName)
    objFolderItem.ModifyDate = CStr(datStamp)
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Sub