Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
MS Outlook Macro for saving message(s) by single click.
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment