The following should work. It will save the message contents of the selected folder and its sub folders in the named folder. Because there can be a lot of messages with little evidence of anything happening it uses a progress indicator which you can download from https://www.gmayor.com/Zips/ProgressBar.zip Import the contents to your Outlook vba editor.
Option Explicit
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 = InputBox("Enter the path to save the messages." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message", "C:\Outlook Message Backup\")
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 - https://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 GoTo Err_Handler
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"
'olMailItem.Save
DoEvents
'End If
End If
Next olMailItem
Unload oFrm
lbl_Exit:
Set oFrm = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
Exit Sub
Err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub
Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - https://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 - https://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 - https://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