Save all messages in outlook folder to local folder

So my goal is to select a folder and then run a macro which will go through every item in the selected folder and save each email to a local folder on my hard drive. I've cobbled together the code below, however I can't get it to run correctly. Whenever I run the macro the first message gets saved as itshould and then my outlook freezes and crashes or it will give me a run-timeerror '-2147287037 (80030003)': Operation failed. If I instead select all messages in the folder and just run the SaveMessageAsMsg () function, it works pretty well except that a few emails are getting skipped. For example I justselected 175 items in the outlook folder, ran SaveMessageAsMsg and only 172were saved. I made sure and checked the message class of all the items in thefolder and they are all "IPM.Note" as specified in the code.

I'm hoping you all will be able to help me with (1) helpingme understand the "BackupEmail" portion of my code is causing outlookto crash or return an error, and (2) help me understand why only 172 out of 175messages are saving when I just run the SaveMessageAsMsg function. And if thereis no fix is there a way to use a MsgBox to tell me exactly which emails needto be manually saved?

[CODE] Public Sub BackupEmails()
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Dim obj As Object

Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items

For Each obj In objItems
With obj
Call SaveMessageAsMsg
End With
Next

Set obj = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing
MsgBox "All attachments have been extracted"

End Sub
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Rem Dim enviro As String
Dim strFolderpath As String

strFolderpath = "C:\Test\"
Rem enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject
sName = Left(sName, 100)
ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

sPath = strFolderpath
Debug.Print sPath & sName
oMail.SaveAs sPath & sName

End If
Next

End Sub

I also have a function to replace the illegal characters inthe file name but for some reason I'm not allowed to post that portion of thecode because of too many URLs or something?

Any help would be appreciated!

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.

Code:

---

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

---