VBA - Email speichern auf Laufwerk

Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim sSenderName As String
Dim optName               As String
Dim inputData As String
enviro = CStr(Environ("USERPROFILE"))
inputData = InputBox("Enter the IPO Number", "Input Box Text")
' Check to see if any data was entered
If inputData  "" Then
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, ""
sSenderName = oMail.SenderName
dtDate = oMail.ReceivedTime
sName = inputData & " " & "from " & sSenderName & sName & Format(dtDate, "yymmdd",  _
vbUseSystemDayOfWeek, _
vbUseSystem) & ".msg"
sPath = "P:\CUSTOMERSERVICE\Kitting_Factory\Spares-Procurement\02_AOG_TEAM\ASOBB3\macro\mail\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End If
Set objItem = Nothing
Set oMail = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
End Sub