Save selected email message as .msg file (with user to choose folder location)

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Hi
The macro below works perfectly to save emails to your hard drive with a date prefix.
However, it only saves to "\Documents".
Is there some code that I can insert so that I can choose the folder path.
Thanks.



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
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Diane
I have tried the above link but no success.
I'm a noob in visual basic so do not know where to place the code, Ive tried what I can but it will not work.
Thanks.
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Also I am not sure whether to apply
"How to use Windows filepaths in a macro" or
"BrowseForFolder Function"
or both?

 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
if you want the windows folder picker, you need to use the browseforfolder function.


Get the function then change your code from
sPath = enviro & "\Documents\"

sPath= BrowseForFolder(enviro & "\Documents\")

this will open the folder browser with the documents folder selected as the default. you can use another default path if you want.
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Diane
I don't know if we are talking about the same thing.
I've used the amended code as shown below and what happens is that it still saves to "\Documents" and this time adds the string of the folder you choose.
What I need is to choose where to save the file. Some emails are saved in one folder while others are saved in a another folder.
Cheers.




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, "yyyy mm dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = BrowseForFolder(enviro & "\Documents\Mobile_add\")
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




Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:
BrowseForFolder = False
End Function
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Diane
The code below now works with some minor tweak. It will save the email to the selected folder.
Now I would like to have the macro remember the last folder location it saved to; so that if I save more than 1 email I do not have to browse through multiple folders each time.
Is this posible?
Thanks.


*

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, "yyyy mm dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = BrowseForFolder(enviro & "\Documents\Mobile_add\")
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




Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:
BrowseForFolder = False
End Function
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
you have two options (probably more, but two i can think of offhand) - one is persistent, the other is remembers only as long as outlook is running.

dim a string variable outside of the macro (under option explicit) then change this line to use it
sPath = BrowseForFolder(previousPath)

At the end of the macro, I'd set previousPath = sPath

the other is to write the path to the registry before exiting the macro and read it into browse for folder. http://www.slipstick.com/developer/read-and-change-a-registry-key-using-vba/ shows how to read/write to the registry.
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Diane, what do you mean by "dim a string variable".
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
It's the stuff at the top of the macro - you need to add one for the new string, previousPath in my example. To put it outside of the macro, it would be like this:

Option Explicit
dim previousPath as string


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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
sorry about that - use
Dim previousPath As Variant

but it starts at that folder - you can't browse up.
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
OK thanks for the effort. Much appreciate it.
Do you think there is any other way?
 

Izbi

New Member
Outlook version
Outlook 2007
Email Account
Diane, anything on this?
Is it possible to use "msoFileDialogFolderPicker" to recall last folder selected?
 

Top