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 httpwww.slipstick.comdevelopersaving-messages-to-the-hard-drive-using-vba ' Late Binding httpmsdn.microsoft.comen-uslibraryofficeff865816.aspx ' Save As Types httpmsdn.microsoft.comen-uslibraryofficebb175283(v=office.12).aspx ' httpwww.access-im-unternehmen.defileadmindownloadOutlookEnumerationen.txt ' Outlook access security httpwww.outlookcode.comarticle.aspxID=52 ' Disable Security prompt in OL2007 Tools->Trust Center->Programmatic Access->Never warn me... ' File Name and Path lenght httpmsdn.microsoft.comen-uslibraryaa365247.aspx ' Save Mail as PDF httpwww.slipstick.comdevelopercode-samplessave-outlook-email-pdf ' Downside of Word PDF slow, no pictures saved, file size bigger than with Acrobat ' Word constants httpwww.visualbasicscript.comrss-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, URHH0T322 - 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, YY-MMDD) 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, 50) 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 ' Matias - filename option date_mail filename_counter ''mail_file_fullname = disk_folder_path & & _ & & _ & mail_filename & _ & mail_counter ' Matias - FCGA filename mail_file_fullname = disk_folder_path & E & mail_received_time & & mail_counter 'for PDF only temp_mail_file_fullname = Environ(temp) & & mail_received_time & _ & mail_filename & _ & _ & 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 httpwww.slipstick.comdevelopersaving-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 httpmsdn.microsoft.comen-uslibrarywindowsdesktopaa365247(v=vs.85).aspx ' Invalid Sharepoint chars httpsupport2.microsoft.comkb905231en-us ' REGEX general httpen.wikipedia.orgwikiRegular_expression ' REGEX in vbscript httpmsdn.microsoft.comen-uslibraryms974570.aspx ' Alternative with array httpwindowssecrets.comforumsshowthread.php60041-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 = REFWFwdAW 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