Full Outlook Archive
Click here for a text file of this script, description below
This is version 2 of my Outlook archive visual basic macro, which was based on my earlier Outlook export to HTML macro, which is retained on this site for reference purposes. This free Macro does the following:
- Automatically Exports all standard Outlook objects (email, contact, calendar entry, read receipt etc) to a user configurable location , proprietory objects (e.g. a special company form) are not supported.
- Retains folder structure.
- Saves Emails as HTML with index number
- Extracts attachments, saves with same index number as the email and adds notification and link to the original email
- NEW FEATURE Saves Calendar entries as both text and .ICS
- NEW FEATURE Saves Contacts as both text and .VCF
- Saves all other objects as text only, with index number
- Extracts any attachments from non-email objects and saves each attachment with the same index number as the object. A Notification is added to the object.
Another new feature, as can be seen from the script, is an example of a command for the script to deal with more than one set of folders (for example you may want to back up an exchange account plus a local PST file or Archive folder, you may also have a series of old PST files you want to back up without having to keep re-entering the script).
A point of note; this script will not work if you have a folder in Outlook called 'Attachments', which is the name of the default folder that all attachments are saved in (as a sub-folder of the one which the email etc is saved in), just give any folder with that name a temporary name like 'Attachments1' or the script will do odd things.
About this script/ Macro
As with my earlier script the reasoning behind writing this is to support the archiving of Outlook contents into something that can be viewed on any platform (primarily Linux and Windows) and indexed by free off the shelf indexing software (such as Google Desktop, Beagle or Copernic Desktop Search).
How to get the code into Outlook/ Install in Outlook
This is a guide for first time users of VB Editor.
To use copy and paste the code from the linked text file into a new Outlook project. To do this click on 'Tools=> Macro=> Visual Basic Editor'. You can also press 'alt+ F11'.
With the Visual Basic Editor Window open look in the top left hand pane. Open up 'Project1 (VbaProject.OTM)' or whatever the top level Project is called, then open the sub-folder 'Microsoft Office Outlook Objects'. Within that there is a file called 'ThisOutlookSession', open this.
You should now have a blank pane on the right. Paste the code from the text file into this pane and it should render as a Sub Function and a Function.
User Options
Now you have the script in Visual Basic Editor you need to enter your user options. These are entered in the sub function 'StartEmailArchive', which is at the top of the code section; the user options are clearly marked.
Path
This must be an absolute file path (i.e. starting at the C:\\ drive) and point to a real folder that you have created. Ideally this should be an empty folder as the script will by default overwrite files with no warning.
StartTheFolder
This refers to the top level folder as seen in your left hand outlook pane. Just change the title in the last set of brackets to the top level name, normally this is 'Personal Folders', or if you are using an exchange server (this script works with them too) its something like 'Mailbox - Users Name'.
Running the Macro
Save the Macro and close the VB editor. Back in Outlook click on 'Tools=> Macro=> Macros' or 'alt+F8' and you will see the one Macro called either 'ThisOutlookSession.StartEMailArchive' or just 'StartEmailArchive'. Select it and click 'Run'. You may have to edit Macro security settings to allow the Macro to run.
The Macro gives no error messages, no status update, and it will reduce Outlook to a quivering wreck whilst it runs; so depending on how full your Outlook folders are you may be waiting a long time. You can either go to lunch, or for a little entertainment go to the folder you entered as 'Path', you should see a slowly growing folder list, and within each folder a growing number of HTML and text files. If you don't see this then something went wrong (e.g. folder path incorrect), check that you entered your user options correctly. For serious errors please contact me.
Code
'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###############################
'Change this absolute path to the already existing folder within your system
'you want to save everything to
Path = "C:\Documents and Settings\UserAcct\My Documents\Mail Export"
'This is set to 'Personal Folders' within the Open instance of Outlook
'which should work for most people. Alternate values like "Archive Folders"
'can be used, insert within the last set of brackets in the same format as
'"Personal Folders"
Set StartTheFolder = Application.GetNamespace("MAPI").Folders("Personal Folders")
'######################################################################
'A value is passed between function and sub to ensure the sub exits
'Function executed
DebugValue = ProcessFolder(StartTheFolder, Path)
'And here we run it again for the archive folders
'####################AND ENTER SETTINGS HERE OR DELETE SECTION#########
Set StartTheFolder = Application.GetNamespace("MAPI").Folders("Archive Folders")
'######################################################################
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 SaveAttachmentsPath As String
Dim TheStrangeItemType As String
On Error Resume Next
'################### PROCESS FOLDER ####################################
'Initial folder processing
SavetoPath = Path & "\" & StartFolder.Name '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