Export Outlook Folders to the File System

'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 & "\" & RemoveIllegalCharacters(olkFld.Name)
    objFSO.CreateFolder strPath
    For Each olkItm In olkFld.Items
        If UCase(olkItm.MessageClass) Like "*NOTE*" Then
            If Not IsEmpty(olkItm.SenderName) Then
                If Not IsEmpty(olkItm.Subject) Then
                    strSubject = RemoveIllegalCharacters(olkItm.SenderName) & " - " & RemoveIllegalCharacters(olkItm.Subject)
                    strFilename = Trim(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
                    If Len(strMyPath) >= 255 Then
                        strMyPath = Left(strMyPath, 200)
                    End If
                    olkItm.SaveAs strMyPath
                    ChangeTimeStamp strMyPath, olkItm.ReceivedTime
                End If
            End If
        End If
    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 = LCase(RemoveIllegalCharacters)
    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, "*", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "@", "_at_")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(9),"")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "û", "u")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "ü", "u")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "à", "a")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "ç", "c")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "é", "e")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "è", "e")
    ' RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "ê", "e")
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