Macro to save selected Outlook 2010 email to a folder as a .msg file

[Biking Loki]

Is there a way, macro or otherwise, to have a one-click solution that will save the selected email to a specific folder? This macro is part of a larger workflow with another program so to have this as a single click function would be very helpful.
Thanks in advance.

 

[Marbles]

This one seems to work okay:

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
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
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

 

[Biking Loki]

That works great. One question though. The macro as it is written deletes the message after saving, correct? Is there a way to either leave it an it current location or move it to an archive folder within outlook?

What I an trying to do is as follows. This macro saves the message to a folder that evernote (EN) monitors. whenever that folder has a file it, EN will import it. Even though the .msg is in EN, I'd like to have a copy in Out as an archive/backup.

 

[Marbles]

It's not deleting my email afterwards. I'll see if I can find the page where it came from.

 

[Biking Loki]

I'm not sure why I thought it was deleting them. I tried it just now and it worked fine. How can I change the folder location? I would like to put it in a folder within the documents folder.

I tried:
sPath = enviro & "\Documents\Test\"

and

sPath = enviro & "\Documents\Test"

Neither worked.

******
I figured it out:

sPath = enviro & "\Documents\" & "\Test\"

 

[Damian Boyd]

Hi,

love this macro. I am wondering if you can add some lines so that it also shows who sent the email, I.e. The file name is to show date, time, subject, sender.

 

[ZubairMughal]

If some one had a trouble with specific path, use as it below. I tried on even Server, its work perfect.

'sPath = "D:\TestOutlook\Test1\"