Save Message As Msg

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

enviro = CStr(Environ("USERPROFILE"))

For Each objItem In ActiveExplorer.Selection

If objItem.MessageClass = "IPM.Note" Then

Set oMail = objItem

sName = oMail.Subject

ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime

sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _

vbUseSystem) & Format(dtDate, "-hhnnss", _

vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

sPath = enviro & "\Documents\"

Debug.Print sPath & sName

oMail.SaveAs sPath & sName, olMSG

End If

Next

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)

sName = Replace(sName, "|", sChr)

End Sub