Save Emails From Outlook To Hard Drive

Ease of Use


Version tested with

2002, 2003 

Submitted by:

Jacob Hilderbrand


This macro will allow you to specify a starting folder and all emails in that folder and all sub folders will be saved to a specified folder on your hard drive. The folder hierarchy will be maintained (i.e. The files will be saved to folders that will be named and have the same structure as the Outlook folders. 


In some cases you may have many many many emails stored on one huge pst file or even several pst files. After a while it can become very hard to maintain all of those files and you want to store them somewhere else. You can export the files / folders, but then you will have to import them to view them later on. With this macro each file will be saved separately and all you have to do is double click it and it will open up in Outlook. 


instructions for use


Option Explicit Sub SaveAllEmails_ProcessAllSubFolders() Dim i As Long Dim j As Long Dim n As Long Dim StrSubject As String Dim StrName As String Dim StrFile As String Dim StrReceived As String Dim StrSavePath As String Dim StrFolder As String Dim StrFolderPath As String Dim StrSaveFolder As String Dim Prompt As String Dim Title As String Dim iNameSpace As NameSpace Dim myOlApp As Outlook.Application Dim SubFolder As MAPIFolder Dim mItem As MailItem Dim FSO As Object Dim ChosenFolder As Object Dim Folders As New Collection Dim EntryID As New Collection Dim StoreID As New Collection Set FSO = CreateObject("Scripting.FileSystemObject") Set myOlApp = Outlook.Application Set iNameSpace = myOlApp.GetNamespace("MAPI") Set ChosenFolder = iNameSpace.PickFolder If ChosenFolder Is Nothing Then GoTo ExitSub: End If Prompt = "Please enter the path to save all the emails to." Title = "Folder Specification" StrSavePath = BrowseForFolder If StrSavePath = "" Then GoTo ExitSub: End If If Not Right(StrSavePath, 1) = "\" Then StrSavePath = StrSavePath & "\" End If Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) For i = 1 To Folders.Count StrFolder = StripIllegalChar(Folders(i)) n = InStr(3, StrFolder, "\") + 1 StrFolder = Mid(StrFolder, n, 256) StrFolderPath = StrSavePath & StrFolder & "\" StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\" If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i)) On Error Resume Next For j = 1 To SubFolder.Items.Count Set mItem = SubFolder.Items(j) StrReceived = ArrangedDate(mItem.ReceivedTime) StrSubject = mItem.Subject StrName = StripIllegalChar(StrSubject) StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg" StrFile = Left(StrFile, 256) mItem.SaveAs StrFile, 3 Next j On Error GoTo 0 Next i ExitSub: End Sub Function StripIllegalChar(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalChar = RegX.Replace(StrInput, "") ExitFunction: Set RegX = Nothing End Function Function ArrangedDate(StrDateInput) Dim StrFullDate As String Dim StrFullTime As String Dim StrAMPM As String Dim StrTime As String Dim StrYear As String Dim StrMonthDay As String Dim StrMonth As String Dim StrDay As String Dim StrDate As String Dim StrDateTime As String Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") If Not Left(StrDateInput, 2) = "10" And _ Not Left(StrDateInput, 2) = "11" And _ Not Left(StrDateInput, 2) = "12" Then StrDateInput = "0" & StrDateInput End If StrFullDate = Left(StrDateInput, 10) If Right(StrFullDate, 1) = " " Then StrFullDate = Left(StrDateInput, 9) End If StrFullTime = Replace(StrDateInput, StrFullDate & " ", "") If Len(StrFullTime) = 10 Then StrFullTime = "0" & StrFullTime End If StrAMPM = Right(StrFullTime, 2) StrTime = StrAMPM & "-" & Left(StrFullTime, 8) StrYear = Right(StrFullDate, 4) StrMonthDay = Replace(StrFullDate, "/" & StrYear, "") StrMonth = Left(StrMonthDay, 2) StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3) If Len(StrDay) = 1 Then StrDay = "0" & StrDay End If StrDate = StrYear & "-" & StrMonth & "-" & StrDay StrDateTime = StrDate & "_" & StrTime RegX.Pattern = "[\:\/\ ]" RegX.IgnoreCase = True RegX.Global = True ArrangedDate = RegX.Replace(StrDateTime, "-") ExitFunction: Set RegX = Nothing End Function Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder) Dim SubFolder As MAPIFolder Folders.Add Fld.FolderPath EntryID.Add Fld.EntryID StoreID.Add Fld.StoreID For Each SubFolder In Fld.Folders GetFolder Folders, EntryID, StoreID, SubFolder Next SubFolder ExitSub: Set SubFolder = Nothing End Sub Function BrowseForFolder(Optional OpenAt As String) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then BrowseForFolder = "" End If Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then BrowseForFolder = "" End If Case Else BrowseForFolder = "" End Select ExitFunction: Set ShellApp = Nothing End Function

How to use:

  1. Open Outlook
  2. Open the VBE (Alt + F11)
  3. From the VBE top menu: Insert | Module
  4. Paste all of the code in the module that was created
  5. Close the VBE
  6. From the Outlook top menu: Tools | Macro | Macros...
  7. Select SaveAllEmails_ProcessAllSubFolders and click Run

Test the code:

  1. After starting the macro you will be prompted for the Outlook folder to process and the local folder to save the files to.
  2. Note this if you have a lot of emails, this will take a while to run.

Sample File:

Module.zip 1.68KB 

Approved by mdmackillop

This entry has been viewed 741 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express