Last active
August 29, 2015 14:08
-
-
Save sio4/20cf6fa8bf72f7c80f9d to your computer and use it in GitHub Desktop.
MS Outlook Macro for saving message(s) by single click.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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