The following will allow you to export the folder you have selected in outlook to a folder on your file system. The messages are exported as msg.
Many thanks to https://techniclee.wordpress.com/2013/05/09/export-outlook-folders-to-the-file-system/
Only changes made –
- Filelength was too long some times
- white spaces in the file path.
- Invalid Characters in the folder path
- Added error handler in to track errors.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | '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 |