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 '2013-09-14 Philipp Post Fix double \\ within file path, change char replacment function '2013-09-16 Philipp Post Add PDF Export and Attachment saving '2013-09-28 Philipp Post Fix Bug when saving Read Confirmations '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 ' http://www.access-im-unternehmen.de/fileadmin/download/OutlookEnumerationen.txt ' Outlook access security: http://www.outlookcode.com/article.aspx?ID=52 ' Disable Security prompt in OL2007: Tools->Trust Center->Programmatic Access->Never warn me... ' File Name and Path lenght: http://msdn.microsoft.com/en-us/library/aa365247.aspx ' Save Mail as PDF: http://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/ ' Downside of Word PDF: slow, no pictures saved, file size bigger than with Acrobat ' Word constants: http://www.visualbasicscript.com/rss-m73963.ashx '-------------------------------------------------------------------------------------------------- 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 mail_subject As String Dim mail_filename As String Dim mail_file_fullname As String Dim temp_mail_file_fullname As String Dim mail_received_time As String Dim mail_counter As Long Dim mail_file_type As String Dim mail_attachment_counter As Long Dim mail_attachment_filename As String Dim mail_attachment_extension As String 'For Folder open dialogue Dim shell_app As Object Dim folder_obj As Object 'For PDF conversion Dim word_app As Object 'Word.Application Dim word_document As Variant 'Word.Document On Error GoTo error_handler Set outlook_app = CreateObject("Outlook.Application") mail_counter = 0 'Change the export format here '----------------------------- 'Allowed file types: txt, msg, mht, pdf 'These work with any message, the other formats (RTF, HTML) do not. 'Recommended is 'msg'. PDF is VERY slow on lots of messages. mail_file_type = "msg" '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) 'If called within Excel 2007 on Win7 , the folder selection window is not the topmost window - press ALT-TAB to display it 'SendKeys ("%{TAB}") 'User canceled folder selection If folder_obj Is Nothing Then Exit Sub End If disk_root_path = folder_obj.self.Path 'Initialize Word for PDF conversion if necessary If mail_file_type = "pdf" Then Set word_app = CreateObject("Word.Application") End If '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 '(do NOT clean out the backslash \ as it is needed for the folder structure) outlook_folder_path = Remove_Illegal_Characters(outlook_folder_path, True) 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 & "\" '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 'Read confirmations do not support the .ReceivedTime property and create the 'exception "Object doesn't support this property or method (438)" 'Exclude them from requesting the ReceivedTime If outlook_mail_item.MessageClass = "Report.IPM.Note.IPNRN" Then mail_received_time = "" Else mail_received_time = Format(outlook_mail_item.ReceivedTime, "YYYY-MM-DD_hhmm") End If 'Shorten overlong mail subjects '(A file or folder name must be limited to 255 chars, ' the full path to 32.767 chars, but recommended is 260 chars) mail_subject = Left(outlook_mail_item.Subject, 100) mail_filename = Remove_Illegal_Characters(mail_subject) 'If the subject did just contain illegal characters or no text at all, create a file name If mail_filename = "" Then mail_filename = "E-Mail" mail_file_fullname = disk_folder_path & mail_filename & "_" & mail_received_time & "_" & mail_counter 'for PDF only temp_mail_file_fullname = Environ("temp") & "\" & mail_filename & "_" & mail_received_time & "_" & mail_counter 'Save the mail based on the selected format Select Case mail_file_type Case "txt" outlook_mail_item.SaveAs mail_file_fullname & ".txt", 0 Case "msg" outlook_mail_item.SaveAs mail_file_fullname & ".msg", 3 Case "mht" outlook_mail_item.SaveAs mail_file_fullname & ".mht", 10 Case "pdf" 'Save as temporary mht outlook_mail_item.SaveAs temp_mail_file_fullname & ".mht", 10 'Convert to pdf (Open in MS Word and save as PDF) Set word_document = word_app.Documents.Open(filename:=temp_mail_file_fullname & ".mht", Visible:=True) 'CreateBookmarks:=0 (wdExportCreateNoBookmarks) 'CreateBookmarks:=1 (wdExportCreateHeadingBookmarks) word_app.ActiveDocument.ExportAsFixedFormat _ OutputFileName:=mail_file_fullname & ".pdf", _ ExportFormat:=17, _ OpenAfterExport:=False, _ OptimizeFor:=0, _ Range:=0, _ From:=0, To:=0, _ Item:=0, _ IncludeDocProps:=True, _ KeepIRM:=True, _ CreateBookmarks:=1, _ DocStructureTags:=True, _ BitmapMissingFonts:=True, _ UseISO19005_1:=False word_document.Close 'Remove the temporary mht file Kill temp_mail_file_fullname & ".mht" Case Else MsgBox "Unknown export file type '" & mail_file_type & "'", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk" Exit Sub End Select 'Save attachements where the format does not do it automatically If mail_file_type "msg" Then 'Go through all attachments For mail_attachment_counter = 1 To outlook_mail_item.Attachments.Count 'Get the attachment file name from Outlook mail_attachment_filename = outlook_mail_item.Attachments(mail_attachment_counter).filename 'Separate file extension and file name mail_attachment_extension = Right(mail_attachment_filename, Len(mail_attachment_filename) - InStrRev(mail_attachment_filename, ".")) mail_attachment_filename = Left(mail_attachment_filename, InStrRev(mail_attachment_filename, ".") - 1) 'Shorten overlong filenames mail_attachment_filename = Left(mail_attachment_filename, 50) 'Cleanup the file name mail_attachment_filename = Remove_Illegal_Characters(mail_attachment_filename) 'Outlook permits to add the same file name twice to a message. 'Put the filename back together and add a counter to be unique mail_attachment_filename = mail_attachment_filename & "_" & mail_attachment_counter & "." & mail_attachment_extension 'Use the mail file name (without extension) plus the attachment name separated by -- as file name '(otherwise it would be unclear to which message the attachment belongs) outlook_mail_item.Attachments(mail_attachment_counter).SaveAsFile mail_file_fullname & "--" & mail_attachment_filename Next End If Next Next 'Close Word if necessary If mail_file_type = "pdf" Then word_app.Quit End If MsgBox mail_counter & " mails saved to disk.", vbInformation, "Save Outlook Messages To Disk" Exit Sub error_handler: If Err.Number = 287 Then MsgBox "Access to Outlook was denied.", vbCritical, "Error accessing Outlook" Else MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk" End If 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 '2013-09-14 Philipp Post Change to REGEX usage '2013-09-15 Philipp Post Add diacritcs replacement and Sharepoint exceptions 'Comments: Used in Save_Outlook_Mails_To_Disk ' Any files or folders in Windows with these chars will not be created :"/\|?* ' MS Sharepoint additionally rejects these: ~#%+. ' However in case of paths (without the drive) the backslash must remain. ' Set keep_backslash to TRUE to do so. 'Readings: Invalid Filesystem chars: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx ' Invalid Sharepoint chars: http://support2.microsoft.com/kb/905231/en-us ' REGEX general: http://en.wikipedia.org/wiki/Regular_expression ' REGEX in vbscript: http://msdn.microsoft.com/en-us/library/ms974570.aspx ' Alternative with array: http://windowssecrets.com/forums/showthread.php/60041-Invalid-Charaters-(VBA) '-------------------------------------------------------------------------------------------------- Function Remove_Illegal_Characters(uncleaned_string As String, Optional keep_backslash As Boolean = False) As String Dim result As String On Error GoTo error_handler result = uncleaned_string With CreateObject("vbscript.regexp") .Global = True '1) Remove RE, FW, Fwd, AW ' The pipe | sign is the separator to add more patterns .IgnoreCase = True .Pattern = "RE:|FW:|Fwd:|AW:" result = .Replace(result, "") '2) Replace slash (/) which often occurs within mail subjects, e. g. US dates, ' ampersand (&), plus (+) with hyphen (-) .Pattern = "[\/\&\+]+" result = .Replace(result, "-") '3) Replace diacritics .IgnoreCase = False ' Uppercase letters .Pattern = "[ÀÁÂÃÄÆÅ]" result = .Replace(result, "A") .Pattern = "[Ç]" result = .Replace(result, "C") .Pattern = "[ÈÉÊË]" result = .Replace(result, "E") .Pattern = "[ÌÍÎÏ]" result = .Replace(result, "I") .Pattern = "[Ñ]" result = .Replace(result, "N") .Pattern = "[ÒÓÔÕÖØ]" result = .Replace(result, "O") .Pattern = "[ÙÚÛÜ]" result = .Replace(result, "U") .Pattern = "[Ý]" result = .Replace(result, "Y") ' Lowercase letters .Pattern = "[àáâãäæå]" result = .Replace(result, "a") .Pattern = "[ç]" result = .Replace(result, "c") .Pattern = "[èéêë]" result = .Replace(result, "e") .Pattern = "[ìíîï]" result = .Replace(result, "i") .Pattern = "[ñ]" result = .Replace(result, "n") .Pattern = "[òóôõöø]" result = .Replace(result, "o") .Pattern = "[ùúûü]" result = .Replace(result, "u") .Pattern = "[ýÿ]" result = .Replace(result, "y") .Pattern = "[ß]" result = .Replace(result, "ss") '4) Remove one or more (= regex +) chars which are NOT one of these: ' a-z A-Z _ 0-9 (= regex ^\w), hyphens (-) and white spaces ' To allow other chars, change the regex like this: [^\w\.@-\\] ' which means: remove non word characters and keep .@- and \ If keep_backslash Then 'Allow backslash: add \\ .Pattern = "[^\w\- \\]+" 'use this if you must allow non latin chars (removes just special chars in the list) '.Pattern = "[\""""\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\\?\/\,]" Else .Pattern = "[^\w\- ]+" 'use this if you must allow non latin chars (removes just special chars in the list) '.Pattern = "[\""""\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\\?\/\,\\]" End If result = .Replace(result, "") '5) Remove leading and trailing white spaces or tabs (TRIM) ' (we could remove tabs \t from here as this is covered in 4) already) .Pattern = "^[ \t]+|[ \t]+$" result = .Replace(result, "") '6) Replace one or more whitespaces or tabs within the text with one underscore .Pattern = "[ \t]+" result = .Replace(result, "_") '7) Remove invalid file or folder name endings for Sharepoint .Pattern = "\.files$|_files$|-Dateien$|_fichiers$|_bestanden$|_file$|_archivos$|" & _ "-filer$|_tiedostot$|_pliki$|_soubory$|_elemei$|_ficheiros$|_arquivos$|" & _ "_dosyalar$|_datoteke$|_fitxers$|_failid$|_fails$|_bylos$|_fajlovi$|_fitxategiak" result = .Replace(result, "") End With Remove_Illegal_Characters = result Exit Function error_handler: Remove_Illegal_Characters = "" MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in function Remove_Illegal_Characters" End Function