A VBA script for Outlook to clean msg files not loading correctly into Outlook due to Internal MAPI errors

msg_cleaner.bas

Sub savemsg()
    Debug.Print "Running..."
  ListFilesInFolder "SOURCE DIR HERE"
End Sub

Sub ListFilesInFolder(SourceFolderName As String)
    Debug.Print "Loading source folder..."
    Debug.Print SourceFolderName
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim strFile, strFileType
    Dim openMsg As MailItem
       
    Dim i As Long
    Dim lngCount As Long
    Dim strFolderpath As String
    
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    i = 1
    For Each FileItem In SourceFolder.Files
        strFile = FileItem.Name
    
        strFileType = LCase$(Right$(strFile, 4))
        If strFileType = ".msg" Then Debug.Print "File"; i; ": "; FileItem.Path
            On Error Resume Next:
                Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
                On Error GoTo 0
                If openMsg Is Nothing Then
                    Debug.Print "ERROR: --" & strFile & "-- not saved..."
                End If
                If Not openMsg Is Nothing Then
                    Debug.Print "Saving message..."
          openMsg.SaveAs "DESTINATION DIR HERE" & i & strFile, olMSG
                    openMsg.Close olDiscard
                    Set openMsg = Nothing
                End If
                i = i + 1
                Next FileItem
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Debug.Print "All done."
End Sub