MS Outlook Macro for saving message(s) by single click.

outlook-macro-save-msg.vb

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 sSender As String
  Dim enviro As String

  enviro = CStr(Environ("USERPROFILE"))
  For Each objItem In ActiveExplorer.Selection
    Set oMail = objItem

    sName = oMail.Subject
    sSender = oMail.SenderName
    RemoveTraceMark sName
    ReplaceCharsForFileName sName, "_"
    ReplaceCharsForFileName sSender, "_"

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

    sPath = enviro & "\Documents\"
    sPath = "M:\"
    Debug.Print sPath & sName
    oMail.SaveAs sPath & sName, olMSG
  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, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Private Sub RemoveTraceMark(sName As String)
  sName = Replace("XXYXX" + sName, "XXYXXRE: ", "")
  sName = Replace(sName, "XXYXX", "")
  sName = Replace("XXYXX" + sName, "XXYXXFW: ", "")
  sName = Replace(sName, "XXYXX", "")
End Sub