'This code was written by E Hopper (www.shappyhopper.co.uk)
'It can be freely used, passed on and edited provided you give the author (me)some credit
'It cannot be used for commercial purposes

'This sub-function is used to start off the archiving function
'This is because the Archiving Function is iterative - it calls itself from within itself
'And that's enough of a headache without working out how to make it user friendly and
'self contained
Sub StartEMailArchive()

    'Declare Variables
    Dim StartTheFolder As Outlook.MAPIFolder
    Dim Path As String
    Dim DebugValue

'####################ENTER SETTINGS HERE###############################

'The first setting is the absolute path to where on your local (or network, depending on speed) hard disk you want
'to save everything to

    Path = "C:\Documents and Settings\shappyhopper\My Documents\Email Export"

'Now there are several options to this script, depending on how you wish to use it

'1) These two lines (the default) lets you pick the folder you want to use, the 2nd line runs the script
    Set StartTheFolder = Application.GetNamespace("MAPI").PickFolder
    DebugValue = ProcessFolder(StartTheFolder, Path)
    
'2) Alternatively you can set up pre-determined folders
    'This first example is for the top level of your folder tree, if you want to archive the lot
    'Set StartTheFolder = Application.GetNamespace("MAPI").Folders("Shappyhopper")
    'DebugValue = ProcessFolder(StartTheFolder, Path)

'3) You can set nested folders in the following way
    'Set StartTheFolder = Application.GetNamespace("MAPI").Folders("RootFolderName").Folders("Level-1 SubFolderName").Folders("Level-2 SubFolderName")…
    'DebugValue = ProcessFolder(StartTheFolder, Path)
        
'4) To run the script on multiple selected folders see the example below.
    'Set StartTheFolder = Application.GetNamespace("MAPI").Folders("Mailbox - Shappyhopper")
    'DebugValue = ProcessFolder(StartTheFolder, Path)
    'Set StartTheFolder = Application.GetNamespace("MAPI").Folders("2008 Email Archive")
    'DebugValue = ProcessFolder(StartTheFolder, Path)


'######################################################################

End Sub


'This Function is designed to iteratively search through the start Outlook Folder and
'its sub folders then re-create the folder structure on a hard disk
' and then archive each of the Outlook emails as individual HTML files
'Attachements are removed and stored on the hard disk within a sub folder
'An HTML link is inserted into the HTML email file linking (relative link) to its original
'attachments
'It has to be called from a seperate sub function which provides the top level folder,
'then it calls itself for each sub-folder

'#WARNING
'Please note this entire process will die horribly if you have any folders called 'Attachments'
'Just change the folder name before you start

Function ProcessFolder(StartFolder As Outlook.MAPIFolder, Path As String)
    
'Declare variables
Dim objEmail As Object
Dim inBoxItems As Outlook.Items
Dim i As Integer
Dim objAttachments As Object
Dim SubjectText As String
Dim SubjectDate As Date
Dim NewSubjectText As String
Dim Length As Integer
Dim Attachments As Integer
Dim Message
Dim objFolder As Outlook.MAPIFolder
Dim SavetoPath As String
Dim SavetoName As String
Dim NewSavetoName As String
Dim Length2 As Integer
Dim SaveAttachmentsPath As String
Dim TheStrangeItemType As String
On Error Resume Next


'################### PROCESS FOLDER ####################################
'Folder processing
'Here we check the folder name for illegal characters

SavetoName = StartFolder.Name
Length2 = 1
NewSavetoName = ""


For Length2 = 1 To Len(SavetoName)
    If (Mid(SavetoName, Length2, 1) = Chr(58)) Or (Mid(SavetoName, Length2, 1) = Chr(92)) Or (Mid(SavetoName, Length2, 1) = Chr(47)) Or (Mid(SavetoName, Length2, 1) = Chr(34)) Or (Mid(SavetoName, Length2, 1) = Chr(60)) Or (Mid(SavetoName, Length2, 1) = Chr(62)) Or (Mid(SavetoName, Length2, 1) = Chr(42)) Or (Mid(SavetoName, Length2, 1) = Chr(63)) Then
    
        NewSavetoName = NewSavetoName & " - "

    Else
        NewSavetoName = NewSavetoName & Mid(SavetoName, Length2, 1)
    
    End If

Next

'Here we make sure the last character isn't a space
Do Until Length2 = 0
    If (Mid(NewSavetoName, Len(NewSavetoName), 1) = Chr(32)) Then
        NewSavetoName = (Mid(NewSavetoName, 1, (Len(NewSavetoName) - 1)))
    
    Else
        Length2 = 0
        Exit Do
    End If
Loop

    SavetoPath = Path & "\" & NewSavetoName 'Set Save to path
    SaveAttachmentsPath = SavetoPath & "\Attachments"
    MkDir SavetoPath 'Create the folder
    MkDir SaveAttachmentsPath 'Create the internal Attachments folder
    
    'Now change their values so that the save-emails & Attchements sections work
    SavetoPath = SavetoPath & "\"
    SaveAttachmentsPath = SaveAttachmentsPath & "\"
        
'################### PROCESS FOLDER CONTENTS ###########################
'Process the email contents of this folder

    'Set the 'INBOX' (used because all this used to do was the inbox) to the startfolder fed to the function
    'Get the items from the folder
    Set inBoxItems = StartFolder.Items
    
    'Sort the emails by date
    inBoxItems.Sort "SentOn", 1
    
    'Set loop counter to 1
    i = 1
    
    'For each of the itms in the selected folder
    For Each objEmail In inBoxItems
     
        'We create a new Mail item for each object in the folder
        Dim mailObj As Object
        Set mailObj = objEmail
    
    'If this is an email item
    If mailObj.Class = olMail Then
      
        'First we check the message format and change to HTML if necessary
        If (objEmail.BodyFormat = olFormatPlain Or olFormatRichText Or olFormatUnspecified) Then
        
           mailObj.BodyFormat = olFormatHTML   'Converts body to HTML if not HTML format
           
        End If
        
        
        'Then we get the attachments
        Set objAttachments = mailObj.Attachments
    
        'If there are some
        If objAttachments.Count > 0 Then
        
        'We add a note to the email
        mailObj.HTMLBody = Chr(60) & "HR WIDTH=100%" & Chr(62) & Chr(60) & "BR" & Chr(62) & Chr(60) & "B" & Chr(62) & "ATTACHMENTS REMOVED - SEE BASE" & Chr(60) & "/B" & Chr(62) & Chr(60) & "BR" & Chr(62) & Chr(60) & "HR WIDTH=100%" & Chr(62) & Chr(60) & "BR" & Chr(62) & mailObj.HTMLBody & Chr(60) & "HR WIDTH=100%" & Chr(62) & Chr(60) & "BR" & Chr(62) & "ATTACHMENTS AS FOLLOWS CAN BE FOUND BY FOLLOWING THE LINKS:" & Chr(60) & "BR" & Chr(62) & Chr(60) & "UL" & Chr(62) & vbCrLf
    
          'for all attachments do...
            For Attachments = 1 To objAttachments.Count
            
                'Add a link to the email NOTE: This is a relative link within a Folder Called "Attachments"
                mailObj.HTMLBody = mailObj.HTMLBody & vbCrLf & Chr(60) & "LI" & Chr(62) & Chr(60) & "A HREF=" & Chr(34) & "Attachments\" & Format(i, "00000") & " - " & objAttachments(Attachments).FileName & Chr(34) & Chr(62) & objAttachments(Attachments).FileName & Chr(60) & "/A" & Chr(62) & Chr(60) & "/LI" & Chr(62) & vbCrLf
                        
                'Save them to save file attachments destination
                objAttachments(Attachments).SaveAsFile SaveAttachmentsPath & Format(i, "00000") & " - " & objAttachments(Attachments).FileName
                
            Next Attachments
        
        'This just ends the bulleted list
        mailObj.HTMLBody = mailObj.HTMLBody & Chr(60) & "/UL" & Chr(62) & vbCrLf
        
        End If
        
        'Then we check the subject text, and remove characters which will kill the function
        SubjectText = objEmail.Subject
        SubjectDate = objEmail.ReceivedTime
        Length = 1
        NewSubjectText = ""
    
        For Length = 1 To Len(SubjectText)
            If (Mid(SubjectText, Length, 1) = Chr(58)) Or (Mid(SubjectText, Length, 1) = Chr(92)) Or (Mid(SubjectText, Length, 1) = Chr(47)) Or (Mid(SubjectText, Length, 1) = Chr(34)) Or (Mid(SubjectText, Length, 1) = Chr(60)) Or (Mid(SubjectText, Length, 1) = Chr(62)) Or (Mid(SubjectText, Length, 1) = Chr(42)) Or (Mid(SubjectText, Length, 1) = Chr(63)) Then
                NewSubjectText = NewSubjectText & " - "
            Else
                NewSubjectText = NewSubjectText & Mid(SubjectText, Length, 1)
            End If
        Next
    
        'Save the HTML Email
        mailObj.SaveAs SavetoPath & Format(i, "00000") & Chr(59) & " " & Format(SubjectDate, "dddd mmmm dd yyyy") & ", " & NewSubjectText & ".html", olHTML
       
        'Counter used to name emails and attachments
        i = i + 1
    
    'Or if this is not an email we have to do our best to save it as a text, ics or vcf file
    'ElseIf (mailObj.Class = 53 Or 46 Or 55 Or 56) Then
    Else
    
        'This was moved here to help format names for both COntacts and Calendar Entries
        SubjectDate = objEmail.ReceivedTime

        'We identify and name the item
        If mailObj.Class = 53 Then
                TheStrangeItemType = "MEETING REQUEST" & " - " & Format(SubjectDate, "dddd mmmm dd yyyy")
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
        
            ElseIf mailObj.Class = 46 Then
                TheStrangeItemType = "RECEIPT" & " - " & Format(SubjectDate, "dddd mmmm dd yyyy")
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
  
            ElseIf mailObj.Class = 55 Then
                TheStrangeItemType = "MEETING DECLINED" & " - " & Format(SubjectDate, "dddd mmmm dd yyyy")
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
                                
            ElseIf mailObj.Class = 56 Then
                TheStrangeItemType = "MEETING ACCEPTED" & " - " & Format(SubjectDate, "dddd mmmm dd yyyy")
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
                
            ElseIf mailObj.Class = 40 Then
                TheStrangeItemType = "CONTACT"
                             
            ElseIf mailObj.Class = 26 Then
                TheStrangeItemType = "CALENDAR ITEM"
                           
            ElseIf mailObj.Class = 48 Then
                TheStrangeItemType = "TASK"
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
                
            ElseIf mailObj.Class = 44 Then
                TheStrangeItemType = "NOTE"
               'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
                
            Else
                TheStrangeItemType = "UNKNOWN CLASS " & objEmail.Class
                'Then we convert the item to plain text
                mailObj.BodyFormat = olFormatPlain
                
        End If
            

        
        'Then we add a note explaining who it was from
        mailObj.Body = "From: " & objEmail.SenderName & "[" & objEmail.SenderEmailAddress & "]" & Chr(13) & Chr(13) & mailObj.Body
    
        'Here we get the attachments
        Set objAttachments = mailObj.Attachments
    
        'If there are some
        If objAttachments.Count > 0 Then
    
          'We make a nice big note to the viewer
          mailObj.Body = Chr(13) & "------------------------------" & Chr(13) & "ATTACHMENTS REMOVED FROM ORIGINAL - SEE BASE" & Chr(13) & "------------------------------" & Chr(13) & Chr(13) & Chr(13) & mailObj.Body & Chr(13) & Chr(13) & "------------------------------" & Chr(13) & "REMOVED ATTACHMENT FILES NAMED AS FOLLOWS CAN BE FOUND IN THE ATTACHMENTS SUBFOLDER" & Chr(13)
    
          'and for all attachments do...
            For Attachments = 1 To objAttachments.Count
            
                'Add a note to the text file that you have removed the attachment and put it somewhere
                mailObj.Body = mailObj.Body & Chr(13) & Chr(42) & " " & Format(i, "00000") & " " & objAttachments(Attachments).FileName
          
                'Save them to save file attachments destination
                objAttachments(Attachments).SaveAsFile SaveAttachmentsPath & Format(i, "00000") & " - " & objAttachments(Attachments).FileName
                
            Next Attachments
    
        End If
        
        'We check the subject text, and remove those characters which will kill the function
        SubjectText = objEmail.Subject
        Length = 1
        NewSubjectText = ""
    
        For Length = 1 To Len(SubjectText)
            If (Mid(SubjectText, Length, 1) = Chr(58)) Or (Mid(SubjectText, Length, 1) = Chr(92)) Or (Mid(SubjectText, Length, 1) = Chr(47)) Or (Mid(SubjectText, Length, 1) = Chr(34)) Or (Mid(SubjectText, Length, 1) = Chr(60)) Or (Mid(SubjectText, Length, 1) = Chr(62)) Or (Mid(SubjectText, Length, 1) = Chr(42)) Or (Mid(SubjectText, Length, 1) = Chr(63)) Then
                NewSubjectText = NewSubjectText & " - "
            Else
                NewSubjectText = NewSubjectText & Mid(SubjectText, Length, 1)
            End If
        Next

        'Here we determine how to save the item
        
        If ((mailObj.Class = 26) Or (mailObj.Class = 40)) Then
        'If it is a Calendar item
            If mailObj.Class = 26 Then
                mailObj.SaveAs SavetoPath & Format(i, "00000") & Chr(59) & " - " & TheStrangeItemType & ", " & NewSubjectText & ".ics", olICal
                mailObj.BodyFormat = olFormatPlain
                i = i + 1
                
            'If it is a Contact
            ElseIf mailObj.Class = 40 Then
                mailObj.SaveAs SavetoPath & Format(i, "00000") & Chr(59) & " - " & TheStrangeItemType & ", " & NewSubjectText & ".vcf", olVCard
                mailObj.BodyFormat = olFormatPlain
                i = i + 1
                
            End If
        End If
        
        'All objects save as Text (include Calendar and Contact
        mailObj.SaveAs SavetoPath & Format(i, "00000") & Chr(59) & " - " & TheStrangeItemType & ", " & NewSubjectText & ".txt", olTXT
        
        'Counter used to name emails and attachments
        i = i + 1
        
    End If
    Next
    
'################### PROCESS SUB FOLDERS ###############################
'Process all the subfolders of this folder by calling this function again within itself
'Gives me a headache thinking about it
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder, SavetoPath)
    Next
    
    'Set the passed variable to nothing to clean up
    Set objFolder = Nothing
    
    'This returns a value to the sub which originally called the function to prevent a bug
    ProcessFolder = 1
    
End Function