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
'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
'               Outlook access security: http://www.outlookcode.com/article.aspx?ID=52
'                  Disable Security prompt in OL2007: Tools->Trust Center->Programmatic Access->Never warn me...
'--------------------------------------------------------------------------------------------------
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 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:\Folder\")
'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
    '(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
        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 = Remove_Illegal_Characters(mail_subject)
        mail_file_fullname = disk_folder_path & 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:

    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
'Comments:      Used in Save_Outlook_Mails_To_Disk
'               Any files or folders with these chars in it will not be created  :"/\|?*
'               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
'               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
    .IgnoreCase = True
    
    '1) Remove RE, FW, Fwd, AW
    '   The pipe | sign is the separator to add more patterns
    .Pattern = "RE:|FW:|Fwd:|AW:"
    result = .Replace(result, "")
        
    '2) Replace slash (often occurs within mail subjects, e.g. US dates) with hyphen
    .Pattern = "[\/]+"
    result = .Replace(result, "-")
    
    '3) 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\- \\]+"
    Else
        .Pattern = "[^\w\- ]+"
    End If
    result = .Replace(result, "")
    
    '4) Remove leading and trailing white spaces or tabs (TRIM)
    '   (we could remove tabs \t from here as this is covered in 3) already)
    .Pattern = "^[ \t]+|[ \t]+$"
    result = .Replace(result, "")
    
    '5) Replace one or more whitespaces or tabs within the text with one underscore
    .Pattern = "[ \t]+"
    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