Save Created Emails as .msg - vba

Question

I have code I use every day. It converts a tab to pdf, creating emails with created pdf attached, and takes subject name from a range.
Example, if that range contains four delivery references, the code creates four emails with same pdf attached.
I want to save these created emails to a Windows folder as .msg.
I tried SaveAs method.
Sub Oval2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim sPath As String
Dim sName As String
Dim rng As Range, c As Range
Set rng = Range("B10:B14")
For Each c In rng.Cells
If c <> "" Then '----------------------------------
Title = c
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & "Information" & ".pdf"
With ActiveWorkbook.Worksheets("Information")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.To = ""
.CC = ""
.Attachments.Add PdfFile
On Error Resume Next
.Display
sPath = "Any folder"
sPath = sPath & m.Subject
sPath = sPath & ".msg"
OutlApp.SaveAs sPath
Application.Visible = True
On Error GoTo 0
End With
'Kill PdfFile
'If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
End If '---------------------------------
Next c
End Sub

Answer 1

VBA coding success increases with use of Option Explicit and limiting use of On Error Resume Next to the rare appropriate situations.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Sub Oval2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim pdfFile As String
Dim Title As String
Dim OutlApp As Object
Dim sPath As String
Dim sName As String
Dim rng As Range
Dim c As Range
' Rare appropriate use of On Error Resume Next
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
' restore normal error handling
On Error GoTo 0
pdfFile = ActiveWorkbook.FullName
Debug.Print pdfFile
i = InStrRev(pdfFile, ".")
If i > 1 Then
pdfFile = Left(pdfFile, i - 1)
Debug.Print pdfFile
End If
pdfFile = pdfFile & "_" & "Information" & ".pdf"
Debug.Print pdfFile
With ActiveWorkbook.Worksheets("Information")
.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
Set rng = Range("B10:B14")
For Each c In rng.Cells
If c <> "" Then '----------------------------------
Title = c
With OutlApp.CreateItem(0)
.Subject = Title
.To = ""
.CC = ""
.Attachments.Add pdfFile
' Inappropriate "On Error Resume Next" removed
.Display
sPath = "Any folder"
'sPath = "C:\Users\username\Test\"
Debug.Print sPath
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
Debug.Print sPath
End If
' error would be bypassed due to poor error handling
' would have been caught by Option Explicit
'sPath = sPath & m.Subject
sPath = sPath & .Subject
Debug.Print sPath
sPath = sPath & ".msg"
Debug.Print sPath
' error would be bypassed due to poor error handling
'OutlApp.SaveAs sPath
.SaveAs sPath
End With
End If '---------------------------------
Next c
'Kill pdfFile
'If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
Debug.Print "Done."
End Sub