'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()
'not use the move function
' 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
Function trimSubject(ByVal theSubject As String, Optional ByVal thePath As String) As String
If Len(theSubject) > 128 Then
trimSubject = Trim(Left(theSubject, 127))
Else
trimSubject = Trim(theSubject)
End If
If Len(thePath & theSubject) > 255 Then
Dim subjectcount As Integer
subjectcount = Len(theSubject) - (Len(thePath & theSubject) - 255)
If subjectcount > 0 Then
trimSubject = Trim(Left(theSubject, subjectcount))
End If
End If
End Function
Sub ExportOutlookFolder(ByVal olkFld As Outlook.MAPIFolder, strStartingPath As String)
On Error GoTo ErrorHanDler
Dim olkSub As Outlook.MAPIFolder, olkItm As Object, strPath As String, strMyPath As String, strSubejct As String, intCount As Integer
strPath = Trim(strStartingPath) & "" & Trim(RemoveIllegalCharacters(olkFld.Name))
objFSO.CreateFolder strPath
For Each olkItm In olkFld.Items
strSubject = trimSubject("[From] " & olkItm.SenderName & " [Subject] " & RemoveIllegalCharacters(olkItm.Subject), strPath)
strFilename = Trim(strSubject) & ".msg"
intCount = 0
Do While True
strMyPath = Trim(strPath) & "" & Trim(strFilename)
If objFSO.FileExists(strMyPath) Then
intCount = intCount + 1
strFilename = Trim(strSubject) & " (" & intCount & ").msg"
' strMyPath = Trim(strPath) & "" & 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

Exit Sub

ErrorHanDler:
MsgBox (strPath)

MsgBox Len(strMyPath)
MsgBox strMyPath

Resume

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