Option Explicit '-------------------------------------------------------------------------------------------------- 'Description: Saves all Messages out of the selected Outlook folder to the Hard Drive 'History 'Date Author Changes '2013-06-19 Diane Poremsky Initial Version '2013-08-13 Philipp Post Change to work inside Excel, bug fixes, change naming convention 'Comments: Does NOT need reference to Microsoft Outlook 12.0 Object Library ' Use of late binding. Needs to declare all Outlook specific types as Variant ' and use CreateObject("Outlook.Application") as in case of missing Outlook Libraries ' the whole vba app stops working 'Readings: Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/ ' Late Binding: http://msdn.microsoft.com/en-us/library/office/ff865816.aspx ' Save As Types: http://msdn.microsoft.com/en-us/library/office/bb175283(v=office.12).aspx '-------------------------------------------------------------------------------------------------- Sub Save_Outlook_Mails_To_Disk() Dim outlook_app As Object 'Outlook.Application Dim outlook_mail_item As Variant 'MailItem Dim folder_counter As Long Dim folder_mail_counter As Long Dim outlook_folders As New Collection Dim outlook_entry_ids As New Collection Dim outlook_store_ids As New Collection Dim outlook_start_folder As Object Dim outlook_folder As Variant 'MAPIFolder Dim outlook_folder_path As String Dim outlook_folder_path_strip_length As Integer Dim disk_root_path As String Dim disk_folder_path As String Dim disk_folder_name As String Dim mail_subject As String Dim mail_filename As String Dim mail_file_fullname As String Dim mail_received_time As String Dim mail_counter As Long 'For Folder open dialogue Dim shell_app As Object Dim folder_obj As Object On Error GoTo error_handler Set outlook_app = CreateObject("Outlook.Application") mail_counter = 0 'Select the Outlook Folder to save to disk 'Opens a folder picker popup window Set outlook_start_folder = outlook_app.GetNamespace("MAPI").PickFolder 'User canceled folder selection If outlook_start_folder Is Nothing Then Exit Sub End If 'Obtain the save to disk root folder 'Opens a folder picker popup window Set shell_app = CreateObject("Shell.Application") 'With start folder set 'Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0, "U:\RHH0T322 - GTM\") 'Without start folder set Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0) 'User canceled folder selection If folder_obj Is Nothing Then Exit Sub End If disk_root_path = folder_obj.self.Path 'Fill the outlook folder structures Call Get_Outlook_Folders(outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_start_folder) 'Go through all folders For folder_counter = 1 To outlook_folders.Count outlook_folder_path = outlook_folders(folder_counter) 'Clean out invalid chars outlook_folder_path = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _ outlook_folder_path, "", ""), _ ":", ""), _ """", ""), _ "/", ""), _ "|", ""), _ "?", ""), _ "*", "") If folder_counter = 1 Then 'Put the selected folder name to the disk 'outlook_folder_path_strip_length = Len(outlook_folder_path) - Len(outlook_start_folder) + 1 'Do not put the selected Outlook folder name to disk outlook_folder_path_strip_length = Len(outlook_folder_path) + 1 End If outlook_folder_path = Mid(outlook_folder_path, outlook_folder_path_strip_length) disk_folder_path = disk_root_path & "\" & outlook_folder_path & "\" disk_folder_name = Left(disk_folder_path, Len(disk_folder_path) - 1) & "\" 'Create directory if missing 'Cannot create a directory tree in one go (folder + subfolder) 'Just one hierarchy item at a time If Dir(disk_folder_path, vbDirectory) = "" Then MkDir (disk_folder_path) End If Set outlook_folder = outlook_app.Session.GetFolderFromID(outlook_entry_ids(folder_counter), outlook_store_ids(folder_counter)) 'Go through all mail items in the present folder For folder_mail_counter = 1 To outlook_folder.Items.Count Set outlook_mail_item = outlook_folder.Items(folder_mail_counter) mail_counter = mail_counter + 1 mail_received_time = Format(outlook_mail_item.ReceivedTime, "YYYY-MM-DD_hhmm") 'shorten overlong mail subjects mail_subject = Left(outlook_mail_item.Subject, 100) If mail_subject = "" Then mail_subject = "No Subject" mail_filename = Clean_Mail_Filename(mail_subject) mail_file_fullname = disk_folder_name & mail_filename & "_" & mail_received_time & "_" & mail_counter & ".msg" 'OlSaveAsType Constants (must also change the file extension) 'olTXT = 0 / olRTF = 1 / olTemplate = 2 / olMSG = 3 / olDoc = 4 '0 and 3 work with any message, the other formats do not outlook_mail_item.SaveAs mail_file_fullname, 3 Next Next MsgBox mail_counter & " mails saved to disk.", vbInformation, "Save Outlook Messages To Disk" Exit Sub error_handler: MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk" End Sub '-------------------------------------------------------------------------------------------------- 'Description: Fills the passed variables with Outlook Folder structures 'History 'Date Author Changes '2013-06-19 Diane Poremsky Initial Version '2013-08-13 Philipp Post Change naming conventions 'Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/ 'Comments: Calls itself recursively to get the full folder tree ' Needed for Save_Outlook_Mails_To_Disk '-------------------------------------------------------------------------------------------------- Sub Get_Outlook_Folders(outlook_folders As Collection, outlook_entry_ids As Collection, outlook_store_ids As Collection, outlook_current_folder As Variant) Dim outlook_subfolder As Variant 'MAPIFolder On Error GoTo error_handler outlook_folders.Add outlook_current_folder.FolderPath outlook_entry_ids.Add outlook_current_folder.EntryID outlook_store_ids.Add outlook_current_folder.StoreID For Each outlook_subfolder In outlook_current_folder.Folders Get_Outlook_Folders outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_subfolder Next Set outlook_subfolder = Nothing Exit Sub error_handler: MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Get_Outlook_Folders" End Sub '-------------------------------------------------------------------------------------------------- 'Description: Makes File and Folder names Windows compatible 'History 'Date Author Changes '2013-08-13 Philipp Post Initial Version 'Comments: Used in Save_Outlook_Mails_To_Disk 'Readings: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx '-------------------------------------------------------------------------------------------------- Function Clean_Mail_Filename(filename As String) As String Dim replacing_char As String On Error GoTo error_handler 'Set the replacement char here replacing_char = "" 'Remove RE, FW, Fwd, AW filename = Replace(filename, "RE: ", replacing_char) filename = Replace(filename, "RE:", replacing_char) filename = Replace(filename, "FW: ", replacing_char) filename = Replace(filename, "FW:", replacing_char) filename = Replace(filename, "Fwd: ", replacing_char) filename = Replace(filename, "Fwd:", replacing_char) filename = Replace(filename, "AW: ", replacing_char) filename = Replace(filename, "AW:", replacing_char) 'Remove double whitespaces filename = Replace(filename, " ", " ") 'Replace single whitespaces with underscores filename = Replace(filename, " ", "_") 'Any files or folders with these chars in it will not be created: filename = Replace(filename, "", replacing_char) filename = Replace(filename, ":", replacing_char) filename = Replace(filename, """", replacing_char) filename = Replace(filename, "/", replacing_char) filename = Replace(filename, "\", replacing_char) filename = Replace(filename, "|", replacing_char) filename = Replace(filename, "?", replacing_char) filename = Replace(filename, "*", replacing_char) Clean_Mail_Filename = filename Exit Function error_handler: Clean_Mail_Filename = "" MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in function Clean_Mail_Filename" End Function