The following outlook macros will save either the selected message or a chosen folder and its subfolders (if any) to the appropriate folders on your local hard drive.
There are a couple of provisos
1. Change strRootPath to the root folder where you wish to save the messages
2. In order to use the 'SaveMessages' macro to process a folder, you will need to download and import the progress Bar userform from the link.
Code:
Option Explicit
'Download and import the contents of https://www.gmayor.com/Zips/ProgressBar.zip
'into Outlook's VBA editor to provide the progress bar.
Private Const strRootPath As String = "C:\Outlook Message Backup\" 'The folder where the sub folders are stored
Sub SaveSelectedMessage()
'Graham Mayor - https://www.gmayor.com - Last updated - 10 Jun 2020
Dim olMsg As MailItem
Dim strPath As String, sStore As String
On Error Resume Next
strPath = strRootPath
Do Until Right(strPath, 1) = Chr(92)
strPath = strPath & Chr(92)
Loop
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
If TypeName(olMsg) = "MailItem" Then
sStore = olMsg.Parent.Store
strPath = strPath & olMsg.Parent.FolderPath & Chr(92)
strPath = Replace(strPath, "\\" & sStore & "\", "")
CreateFolders strPath
SaveMessage olMsg, strPath
Else
MsgBox "No mail item selected"
End If
lbl_Exit:
Exit Sub
End Sub
Sub SaveMessages()
'Graham Mayor - https://www.gmayor.com - Last updated - 08 May 2019
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace
Dim strPath As String
Dim sSubPath As String
Dim sStore As String
strPath = strRootPath
Do Until Right(strPath, 1) = Chr(92)
strPath = strPath & Chr(92)
Loop
Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
'cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
cFolders.Add olNS.PickFolder
Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
sStore = olFolder.Store
sSubPath = Replace(olFolder.FolderPath, "\\" & sStore & "\", strPath)
CreateFolders sSubPath
ProcessFolder olFolder, sSubPath
If olFolder.folders.Count > 0 Then
For Each SubFolder In olFolder.folders
cFolders.Add SubFolder
Next SubFolder
End If
Loop
lbl_Exit:
Set olFolder = Nothing
Set SubFolder = Nothing
Exit Sub
End Sub
Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String)
'Graham Mayor - http://www.gmayor.com
Dim olItems As Outlook.items
Dim olMailItem As Object
Dim i As Long
Dim oFrm As New frmProgress
Dim PortionDone As Double
On Error Resume Next
Set olItems = olMailFolder.items
oFrm.Show vbModeless
i = 0
For Each olMailItem In olItems
i = i + 1
If TypeName(olMailItem) = "MailItem" Then
'If Not olMailItem.categories = "Backed-up To File" Then
PortionDone = i / olItems.Count
oFrm.Caption = olMailFolder.Name & " - Processing " & i & " of " & olItems.Count
oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
SaveMessage olMailItem, sPath
'olMailItem.categories = "Backed-up To File"
DoEvents
'End If
End If
Next olMailItem
Unload oFrm
lbl_Exit:
Set oFrm = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
Exit Sub
End Sub
Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, sPath, fname
lbl_Exit:
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While oFSO.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function
Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function