Introduction
This code will traverse all Outlook folders and save each mail item as an individual file keeping the folder structure. The code is very basic without a user interface. It's a simple example of how email messages can be stored individually instead of one big pst file for example.
Background
Someone I know wanted to store his email messages as individual files and not in one large file as done by the export functionality of Outlook. This code will do just that.
Using the Code
When Visual Basic editor is opened in Outlook and the code below is copy-pasted into it, this can immediately run and will store all mail items from the inbox to the C:\Temp folder. The method to start is SaveAllMail. If the immediate window is opened, it will also give some progress feedback.
Option Explicit
Const PATHSEPARATOR = "\"
Const MAIL_DIRECTORY = "C:\Temp"
Const MAIL_SAVETYPE = olMSG ' olHTML, olMSG, olRTF, olTemplate,
'olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode.
Const MAIL_SAVEFILE_EXT = ".msg"
- MAIL_DIRECTORY - Directory where the items are saved
- MAIL_SAVETYPE - File type of the saved mail item
- MAIL_SAVEFILE_EXT - File extension of the saved mail item
These constants define how the mail items are stored where the values for MAIL_SAVETYPE and MAIL_SAVEFILE_EXT are related to each other. When, for example, the MAIL_SAVETYPE is changed to olHTML, the value for MAIL_SAVEFILE_EXT should also be changed so it will match the output file format. In the case of olHTML, this should of course be ".htm" (or ".html" if you like).
Public Sub SaveAllMail()
' Save all mail items in the inbox folder
ProcessFolder ThisOutlookSession.Session.GetDefaultFolder(olFolderInbox), _
MAIL_DIRECTORY, True
' The line below would scan all outlook folders.
'ProcessFolders ThisOutlookSession.Session.Folders, MAIL_DIRECTORY, True
End Sub
The method SaveMailItem is the main method in this example. The current starting point is the inbox folder. Because this is a single folder, the ProcessFolder is called. The second start point that is currently commented must be used for a collection of folders.
As an example, when only the subfolders of the inbox must be stored but not the mail items in the inbox itself, the following could be used:
ProcessFolder ThisOutlookSession.Session.GetDefaultFolder(olFolderInbox).Folders, _
MAIL_DIRECTORY, True
Public Sub ProcessFolder(Folder As Outlook.Folder, ByVal Directory As String, _
ByVal Recursive As Boolean)
Dim FolderDirectory As String
FolderDirectory = Directory & PATHSEPARATOR & Folder.Name
CreateDirectory FolderDirectory
DebugPrint Folder.Name
ProcessItems Folder.Items, FolderDirectory
If Recursive Then
ProcessFolders Folder.Folders, FolderDirectory, Recursive
End If
End Sub
Public Sub ProcessFolders(Folders As Outlook.Folders, _
ByVal Directory As String, ByVal Recursive As Boolean)
Dim Folder As Outlook.MAPIFolder
For Each Folder In Folders
ProcessFolder Folder, Directory, Recursive
Next
End Sub
The two methods above handle the folder and folders that are found. The functions call each other recursively (if the Recursive parameter is true) in a way that each folder will traverse all subfolders and each folder in these subfolders is the point where this recursively starts over again.
Private Sub PrintMailItemsProcessed(NumOfProcessedItems As Long)
DebugPrint " Mail items processed: " & CStr(NumOfProcessedItems)
End Sub
The PrintMailItemsProcessed method above is simply used for printing the processed mail items to the debug window.
Private Sub ProcessItems(Items As Outlook.Items, ByVal Directory As String)
Dim Item As Object, MailItemNumber As Long
MailItemNumber = 0
DebugPrint " Total number of items: " & CStr(Items.Count)
For Each Item In Items
Select Case True
Case TypeOf Item Is Outlook.MailItem
MailItemNumber = MailItemNumber + 1
MailItemToFile Item, Directory, MailItemNumber
If (MailItemNumber And 7) = 7 Then
PrintMailItemsProcessed MailItemNumber
End If
Case TypeOf Item Is Outlook.ContactItem
' ...
Case TypeOf Item Is Outlook.MeetingItem
' ...
Case TypeOf Item Is Outlook.JournalItem
' ...
Case Else
' ...
End Select
Next
PrintMailItemsProcessed MailItemNumber
End Sub
The ProcessItems method is where the items are identified and a specific method for that item can be called. Only the MailItem is currently processed, but some other item types are identified but are left empty. There are even more item types that aren't identified in this example.
Private Sub MailItemToFile(Item As Outlook.MailItem, _
ByVal Directory As String, ItemNumber As Long)
Item.SaveAs Directory & PATHSEPARATOR & CStr(ItemNumber) _
& " - " & ReplaceIllegalChars(Item.Subject) & MAIL_SAVEFILE_EXT, MAIL_SAVETYPE
End Sub
The MailItemToFile method will store a given mail item to the corresponding directory in the defined format. The method doesn't save the attachments to files but this is something that one could easily add him/herself. Just traverse the attachments of the mailitem and store each attachment to a given location, something like the example below:
For Each Item In Item.Attachments
Atmt.SaveAsFile Directory & PATHSEPARATOR & CStr(ItemNumber) & " " & & Atmt.FileName
Next Atmt
'-----------------------------------------------------------------------------------------
' Some general methods used
'-----------------------------------------------------------------------------------------
Private Sub DebugPrint(ByVal DebugMessage As String)
Debug.Print DebugMessage
DoEvents
End Sub
The DebugPrint method simply will print some information to the immediate window and a DoEvents call is added to prevent Outlook from "Not responding".
Public Sub CreateDirectory(ByVal Directory As String)
If Dir(Directory, vbDirectory) = vbNullString Then
MkDir Directory
End If
End Sub
' This function will replace all illegal characters with the ReplaceChar
Private Function ReplaceIllegalChars(S As String, _
Optional ReplaceChar As Byte = 32) As String
Dim index As Integer, CharArray() As Byte, ResultArray() As Byte
If Len(S) > 0 Then
CharArray = StrConv(S, vbFromUnicode)
ReDim ResultArray(UBound(CharArray))
For index = 0 To UBound(CharArray)
Select Case Chr(CharArray(index))
Case "/", "\", ":", "?", "*", "<", ">", "|", """"
ResultArray(index) = ReplaceChar
Case Else
ResultArray(index) = CharArray(index)
End Select
Next
ReplaceIllegalChars = StrConv(ResultArray, vbUnicode)
Else
ReplaceIllegalChars = vbNullString
End If
End Function
The ReplaceIllegalChars will strip the characters from a given string that aren't allowed in a filename and is used in this example to strip illegal characters from the mail subject before using it as filename. The character will be replaced with the one given in the ReplaceChar parameter. This must be a single byte value that represents the ASCII value of the character. The built-in Asc function can be used in this case to convert the character to the ASCII value.
When looking into the code of this function, you may notice that S is converted to a byte array and an equivalent array is defined to hold the result. In this way, the memory needed can be allocated at once instead of adding just one character at a time. This method of processing characters in a string is notably faster when dealing with large string values.
Points of Interest
This example is, as mentioned at the beginning, very basic and something you can extend easily to provide functionality for all your wishes. It's a working starting point for exploring other possibilities Outlook has and that perhaps could make your life a bit easier by automating it.
