This code sample will save one or more selected messages to your My Documents folder as individual .msg files. The file name includes the received date and time. Spaces and invalid characters are replaced with underscores.
A variation of this macro that saves as a text file is at Save email message as text file. Included is a version that saves selected messages as one text file. For more information on saving to other formats, see How to Save Email in Windows File System.
See How to use the VBA Editor if you don't know how to use macros or the VBA Editor.
Updated December 17 2014: macro checks for message class and skips meetings and report/receipt messages. I also added character replacements for single quote and asterisk.
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
If objItem.MessageClass = "IPM.Note" Then
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
End If
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End SubPick the Folder Location
To select the folder where you want to save the selected messages, you can use the BrowseForFolder function. You'll need to select the folder before you begin saving the messages. If you select it after the For Each loop, you'll need to select a folder for each message.
Don't forget to get the BrowseForFolder function.
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
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder
' get the function at http://slipstick.me/u1a2d
strFolderpath = BrowseForFolder(enviro & "\documents\")
' Cleanly exit if Cancel is clicked
If StrFolderpath = "False" Then
Cancel = True
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
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 = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End SubSave messages as they are sent
This version of the macro will save messages to the user's My Documents folder as they are added to the Sent Items folder, using "Now" to create the time and date stamp. If the subject contains illegal filename characters, you'll need the ReplaceCharsForFileName sub above.
Private WithEvents objSentItems As Items
Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End SubUse a Userform to display locations to choose from
This version of the macro uses a userform to display locations to choose from.
To use this macro, you need to put this line in a module, not in Thisoutlooksession.
Public lstNum As Long
This code goes into ThiOutlookSession:
Option Explicit
Public WithEvents objSentItems As Items
Public Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Dim objNS As Object
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Public Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim dtDate As Date
Dim sName As String
Dim sPath As String
UserForm1.Show
Debug.Print lstNum
Select Case lstNum
Case -1
' -1 is what you want to use if nothing is selected
sPath = "C:\Users\slipstick\Documents\"
Case 0
sPath = "C:\Users\slipstick\Documents\Email Attach\"
Case 1
sPath = "C:\Users\slipstick\Documents\pics\"
Case 2
sPath = "C:\Users\slipstick\Documents\Balsam Lake\"
End Select
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End Sub
Public Sub ReplaceCharsForFileName(sSubject As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
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 SubThis code goes into the UserForm. Name the OK button btnOK. See VBA UserForm sample: Select from a list of templates for step-by-step instructions to design the userform.
Private Sub UserForm_Initialize()
With ListBox1
.AddItem "Email Attach"
.AddItem "pics"
.AddItem "Balsam Lake"
End With
End Sub
Private Sub btnOK_Click()
lstNum = ListBox1.ListIndex
Unload Me
End Sub
When you send a message, the userform comes up with the list of folder locations to choose from.
How to use the macros on this page
First: You need to have macro security set to low during testing. The macros will not work otherwise.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Some macros need to be in ThisOutlookSession, others go into a module or can be placed in either ThisOutlookSession or a module. The instructions are below.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
To put the macro code in ThisOutlookSession:
- Expand Project1 and double click on ThisOutlookSession.
- Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
More information as well as screenshots are at How to use the VBA Editor
More Information
- How to Save Email in Windows File System
- Import Messages from File System into Outlook Folders
- OWA: Save Messages to My Documents
- Save a Message as HTML and Delete the (Annoying) Folder
- Save email message as text file
- Save Outlook Email as a PDF
- Saving All Messages to the Hard Drive Using VBA
To save all incoming messages as files as they arrive in your Inbox, see E-Mail: Save new items immediately as files (VBOffice.net)
KBa says
Hi everybody,
How can I deleta an e-mail in Outlook after copying it to a disk?
KBa says
How to remove an e-mail after it has been saved as an *.msg file?
Duy Pham says
Hello Diane,
Thanks for your sharing, it has been a of a great help for me in daily task now!
However, Due to the requirements of my job, I want to set the file name by the principle: items in content body email+year/month/day_number of ascending from 1..n.
For example, here is the body content email:
From: xxx@yyy.zzzz
Sent: 15 August, 2023 8:34 AM
To: pic@abc.com
Subject: Notice of change of e-invoice
" Dear: ABC Company (MST: 0345287134)
Invoice of Company with information:
- Invoice form symbol: 1
- Invoice symbol: C23TYY
- Invoice number: 10
- Date of establishment: August 14, 2023
- Seller of goods and providing services: XYZ CO., LTD (MST:2912857402) Has been replaced by invoice form symbol: 1, invoice symbol: C23TYY, invoice number: 12, date of making : 15/08/2023 In case you need more detailed information, please contact the seller of goods and provide services.
Sincerely thank you! "
With this email, i would like to save as msg file with the name:
0345287134_20230815-1
If have more email from this supplier, the name file will be:
0345287134_20230815-2
0345287134_20230815-3
.....
0345287134_20230815-n
Hope to have your continued support, thanks you!
Jon D says
Hi Diane,
I hope you are doing well.
I was wondering if you are still responding to comments from this article? This code has proven so valuable to me but I am having some issues trying to change the folder path to which I want the emails saved when running the code.
May I ask if you can could please offer some input? I want to change to a folder I've created inside my Documents folder but I can't get them there for some unknown reason. I'm very new to all of this so I'm not entirely sure as to how to incorporate other functions into the code if that is required (?). I'm using the default code (the first one in the article). I have a folder called 'OLAttachments' in my Documents folder but I've tried changing the path in the script to the full one that leads to that to no avail.
I'm at a standstill here and would be more than grateful for any and all help.
I wish you all the best!
Danick says
Hi Diane
Been using this VBA for years and am now finding that my Office 365 which has just been updated by the company is now giving that error message,
"Cannot Open MSG File (Error: We can't open .msg. Its possible the file is already open, or you don't have permission)"..
The work around is to go into File Explorer and select the file properties and change it to Read-Only. This works, but a real pain to do it every time.
Here's a ref to the error.
https://answers.microsoft.com/en-us/outlook_com/forum/all/cannot-open-saved-msg-file/095ff296-5fd1-44fa-955c-61e4f4197430?page=1
Thought maybe there is a one liner I could add to the VBA that would automatically save the .msg file with read-only property. Do you know if that could be done? Then I'd just make the line in-active if Microsoft ever fixes this thing again. It took them 5 years to fix it the last time...
Thanks
Zack W says
This is really wonderful - thank you for your contribution!
Rather than run on selected messages, is there a way to loop through the entire contents of a PST file (including subfolders)? I'm trying to do some mass backups, and this would be incredibly useful.
Wim Meeus says
Hi All,
I used this script with success but faced issues with path/filename length.
It would be nice that at least the name of the msg file would be shortened till the maximum length.
I'm not sure how to implement it so any help is appreciated.
Diane Poremsky says
This block sets the file name -
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
the first two lines use the subject and remove characters that are illegal in the file name. If you have a long subject, you can shorten it - this gets the first 20 characters of the subject.
sName = left(item.subject, 20)
This would remove illegal characters instead of replacing them
ReplaceCharsForFileName sName, ""
The next part is the received date - in 20211028-080822 format. The reason for using the full time is in the event there are two messages with the same subject and received minute.
You can shorten it to 2110280808 by removing 2 2's, the -, and the s's from the date format.
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "hhnn", _
vbUseSystemDayOfWeek, vbUseSystem)
This line puts the two together - you can remove '& -' to use "2110280808subject-20-character"
& "-" & sName & ".msg"
Rafael says
Hello Diane,
Thanks for your script, it has been a of a great help for me for almost 2 years now. Which is fantastic.
However, last week I updated from MS 2010 to O365 and since then the first time Outlook lauches all the new e-mails that were received overnight (when outlook was closed) are not flagged as new items and not backed up. The scripts starts normally and save all the new messages after outlook is opened, but I miss the automatick backups on the ones received overnight.
I've been manually saving those few e-mails, but was wondering if you have had (or know about) any similar issue and knows how I can work around it.
Appreciate your time and Attention
Diane Poremsky says
What type off email account are you using? It shouldn't matter... and there should be no differences with the versions.
David says
Your VBA was updated to skip meetings and report/receipt messages. How do you include all selected items.
Diane Poremsky says
Remove this line and the matching End if. Then it will run on all items.
If objItem.MessageClass = "IPM.Note" Then
Raf Verschueren says
Hi Diane,
If I remove the line and matching End if, I get an error on Set oMail = objItem (Types don't match) when I try to safe a receipt message.
Diane Poremsky says
is objItem and omail dim'd as an object or mailitem? They needs to be object to work on non-email items.
Raf Verschueren says
Hi Diane,
Thanks for your response.
I tried to reply but it can't see my reaction so new attempt.
The code now is:
Dim oMail As Outlook.MailItem
Dim objItem As Object
When I change Outlook.MailItem into Object I get "Error 438 during execution. This feature or method is not supported by this object."
Diane Poremsky says
The code sample is working for me, for both email and meeting invites. (That's all I have in my test mailbox).
20210322-005132-subject.msg
20211020-115819-Declined- .msg <== meeting response
20210612-131347-Testing moving.msg <== meeting invite
Raf Verschueren says
I'm working with Office 365 in Belgium.
It's not a meeting but a report/receipt message.
Can that be the problem?
Raf Verschueren says
Complete code:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Object
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, ":", 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
Matt B says
Were you able to get your Received/Read Receipts to save?
I've also been trying to get this to work for some time. I've tried using *REPORT.IPM.NOTE.IPNRN and REPORT.IPM.NOTE.DR instead of IPM.Note, but neither one worked.
Nothing works unless it's IPM.Note (which Note can not be NOTE to work.)
Any further help would be great.
Flavio Moutinho says
Private WithEvents objSentItems As Items Private Sub Application_Startup() Dim objSent As Outlook.MAPIFolder Set objNS = Application.GetNamespace("MAPI") Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items Set objNS = Nothing End Sub Private Sub objSentItems_ItemAdd(ByVal Item As Object) Dim sPath As String Dim dtDate As Date Dim sName As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) sName = Item.Subject ReplaceCharsForFileName sName, "-" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "-hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg" sPath = enviro & "\Documents\" Debug.Print sPath & sName Item.SaveAs sPath & sName, olMSG End SubFlavio Moutinho says
Hello, I was in need of a macro so as to send or reply to a message, create a .msg file, I'm not getting it, could you help me?
Robert says
Hello,
I have been trying to use this script to save the emails from a public folder within Outlook but keep getting the error "Path Not Found". The script works fine with a small test folder under my inbox, so instantly I know the script can't see the Public Folder. I tried to modify the script using the info found here (olPublicFoldersAllPublicFolders ), but I can not get it to work properly for the life of me. Any help you can offer would be greatly appreciated!
Michael Petrozelli says
Hi Diane, a while back you greatly helped me with an Outlook rule script to move an email to a network folder. Now I have to add a timestamp and can't for the life of me get it to work:
Public Sub saveAttachtoDisk3(olItem As Outlook.MailItem)
Dim olAttachment As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "\\10.33.XX.XXX\folder\Auto Email Attachments\"
Dim dateandtime As String
dateandtime = DateTime.Now.ToString("yyyy/MM/dd HH:mm:ss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & olAttachment.DisplayName
Set olAttachment = Nothing
Next
End Sub
Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)
saveAttachtoDisk3 objItem
End Sub
It prompts me for Object required, but I'm not sure what else is needed for it.
Diane Poremsky says
>> dateandtime = DateTime.Now.ToString("yyyy/MM/dd HH:mm:ss")
Is not a valid file name.
Try using this:
dateandtime = format(Now, "yyyyMMdd_HHmmss")
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
if you need to use the date at the end, you will need to get the file extension and add it.
' get the last 5 characters for the file extension
strExt = Right(olAttachment.DisplayName, 5)
olAttachment.SaveAsFile SaveFolder & "\" & olAttachment.DisplayName & dateandtime & strExt
https://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/
Michael Petrozelli says
Thanks so much Diane, I notice that it appears to be maybe (?) grabbing the clock time, and was wondering if instead it could do ReceivedTime based on when Outlook is receiving it?
I checked, and both Outlook and the PC clock are both set to the same exact time UTC Eastern.
Diane Poremsky says
This gets the received time - dtDate = oMail.ReceivedTime
you could try omail.senton that gets you the time the sender sent it - which should only be a few seconds or so before you receive it.
Michael Petrozelli says
Diane, if I want to get both would it look like this:
Dim olAttachment As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "xxxxxxxxxx"
Dim dateandtime As String
dtDate = oMail.ReceivedTime
Dim dtDate As Date
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
Set olAttachment = Nothing
Michael Petrozelli says
Sorry to bother you Diane, but would you mind telling me if the below code is scripted properly (May 20th)?
Diane Poremsky says
Oh, sorry. I read it as saying it that is what you got working, not asking me if it was correct. 50 lashes with a cold wet noodle. (It's hot today... a cold noodle might be refreshing, not punishment. LOL)
The code is good - but you are using 'now' not the received time in dateandtime variable - is that what you wanted? (the DIM need to be before you set the value too.)
Dim dateandtime As String
Dim dtDate As Date
dtDate = oMail.ReceivedTime
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
If you want the filename to be the received date, use
dtDate = oMail.ReceivedTime
dateandtime = Format(dtDate, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
or for a shorter version:
dateandtime = Format( oMail.ReceivedTime, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
If you want both now and the received date, you need to format the received date.
dtDate = Format(oMail.ReceivedTime, "yyyyMMdd_HHmmss")
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
Michael Petrozelli says
You're the best, thanks so much Diane!!!
Andy says
Hi,
This is awesome, thanks!
One question: if I run the code on a lot of selected emails the code stops running after 200 emails because it seems to think I have 200 emails "open" and my system admin has set a limit on this. Is there something that can be added to the code that will effectively close each mail item after it's been saved to the file system in order to prevent this?
Thanks.
Diane Poremsky says
close the message after saving:
oMail.SaveAs sPath & sName, olMSG
oMail.Close olDiscard
Andy says
Hi,
This is awesome, thanks!
One question: if I run the code on a lot of selected emails the code stops running after 200 emails because it seems to think I have 200 emails "open" and my system admin has set a limit on this. Is there something that can be added to the code that will effectively close each mail item after it's been save to the file system in order to prevent this?
Thanks.
mastho sonander says
Hello, this post, just to say Thank You!
You saved my day :-)
Take care
Gustavo Britto says
Good night Diane, how are you? Please, could you help me? I have a doubt, how do I do if the files exist he warns before overwriting for the user to be aware.
Diane Poremsky says
You want a warning if the file exists?
You'd use something like this:
if Len(Dir(sName)) > 0 then
' save
end if
Yohann says
Hello, how can we adapt it to apply to the message that has just been sent? Thank you! Yohann
Diane Poremsky says
You would use an itemadd macro and watch the sent folder. The macro in the heading 'Save messages as they are sent' will do it.
Yohann says
Hello Diane, many thanks.
I have now 2 macros: the one watching the sent folder, so that I can save the "just sent" email; the second one enables to save any email or group of emails in any folder (I select the email(s) in any folder of the main window of Outlook (Inbox, Sent Items, etc.), then I launch the macro).
It is quite practical, but the must-have would also to enable the saving of an email that is opened in its own window; for example, I open any email by double-clicking, then I can save it directly from that opened window, without having to go back into the folder of the main window of Outlook in which the email is stored.
Do you know if there is a way to define the window that has the focus please?
Thank you in advance.
Yohann
Diane Poremsky says
That is possible - use the GetCurrentItem function to work with either opened or selected items. (It will only work with 1 open item, not all if you have several open)
This line goes in the macro, replacing the one that uses the selected item (replace objitem with the object name you are using)
Set objItem = GetCurrentItem()
and get the function from here:
https://www.slipstick.com/developer/outlook-vba-work-with-open-item-or-select-item/
Yohann says
Excellent; thank you very much Diane
Yohann says
Hello Diane,
happy new year!
My macros work quite well, but there is something boring. Indeed, for I use "olFolderSentMail" to suggest the recording of each sent email, if we open Outlook in a second environment (e.g. on another computer) after having sent some emails in a 1st environment, when that other Outlook session updates (including the Sent Mail folder), the macro runs to suggest the recording of each email that has already been sent and eventually recorded in the 1st session. If there is only one email, that's okay (but not great), but if there are several ones...
Could you please tell me how we can get around that difficulty?
Thank you in advance.
Yohann
Diane Poremsky says
to avoid that, you need to set a property on the message after it is processed - this could be a hidden custom field, a category, a completed flag etc - then check for that value and skip any that have that field set.
Prado says
Hi Diane,
Thanks a lot, this all save a lot of time.
A took the "Save messages as they are sent" code and apply the Nik reply changes.
Therefore, now all incoming messages that go through the rules are saved in a specific folder.
But, i'd like to save in different folder, as an exemple: messages that has in the subject "Company 01-2020", the message will be saved in the 01-2020 folder. Could you help me doing that?
Thanks in advance and sorry for my english :/
Gary Blair says
Hi Diane,
I'm a total novice with VBA, I started with what you and others have provided in different posts and have been able to put together a Macro to save selected emails as .msg to a folder that I can select/create.
It's working great but I can't figure out how to have it automatically rename a file by adding filename(1).msg if the files exists instead of overwriting.
Hope you can help, here's what I've got.
Public Sub Save_Email_As_Msg_Select_Folder()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim SenderName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\\")
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
SenderName = oMail.SenderName
ReplaceCharsForFileName SenderName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy-mm-dd_h-nn-ss AM/PM", vbUseSystemDayOfWeek, _
vbUseSystem) & "_" & sName & "_From-" & SenderName & ".msg"
sPath = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), 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
reach4thesky says
how to add timestamp after .msg extension?
Diane Poremsky says
I'm not sure I'd do that but its just a matter of changing the order in sname variable:
sName = sName & ".msg" & Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem)
Shahrooz Bral says
Hi Daine,
wishing you a good day.
I am using your code SaveMessageAsMsg() but when i search a email in All mailboxes and after finding email , this function does not work.
please let us know how to change a part of code to use it.
Diane Poremsky says
it's not working on the search results? The first 2 should work on search results - I'll double check.
Michelle says
Hello Diane,
Thank you for the fabulous code--it's a real time saver!
Would you know how to run this macro and have automatic replies included? They are not saved when the macro is run.
I am new to this but have tried looking in the comments and searching Google, and have not found my answer. I'd really appreciate it if you could help me out.
Thank you,
Michelle
Isaac Cheng says
Hi Daine,
Thanks for the sharing.
However, when I run the code, it appears Run-time error. I tried to debug the highlighted row is on oMail.SaveAs sPath & sName, olMSG
What i am trying to do is I would like to save a specific email with the same SUBJECT+current date to a specific folder with named 'today date.
Do I need to change any parameter from your code? Also the place i would like to save is a company network drive, sth like M:\HK\Dailytest\
Thanks.
Diane Poremsky says
It may be the fact that you are trying to save to a network drive - Outlook (and macros) can be funny about network drives. On the other hand, in looking at the screenshot, it looks like you are using the original code, which saves to the user's Documents folder.
Open the immediate window - (Ctrl+G or look on the View menu) - the Debug.print line writes the file path there so you can see if its correct.
Andy says
Diane, I have been using your program and it is great (here it comes)...but, I noticed if a start out with 3,180 emails when I finish running your program that I only get 2,924 .msg files? Figuring that it's encountering messages with the same received date and subject that its simply overwriting the files. So I tried changing the sname item to EntryID which is the closest thing I can find to a unique identifier for email and the numbers are the same? Do you have any suggestions?
Thanks
Diane Poremsky says
I would use the current (saved) date and time (its a shorter value than the entryid) or number the saves (i have a macro here somewhere that does this).
You could use the current time (as hhnnss) as a unique number:
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & Format(Time, "-hhnnss-") & sName & ".msg"
Andy says
Diane, I want to thank you and apologize. When I ask my question above, I broke the cardinal rule. That rule was to read all of the prior comments before posting a new question. In one your prior response to a comment you mentioned an icount feature. This icount feature coupled with the subject provided me with enough uniqueness. So no overwrites! In my application of your code current time was not unique enough. I can't tell you how much time this code will save me! Again thanks, happy holiday and a prosperous new year!
Diane Poremsky says
You are forgiven... 221 comments is a bit much to make you read all of them. :)
Glad you got it solved.
Deros says
The code above works great on normal email messages. the code uses "IPM.Note"...
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
What do I need to change in the code to allow it to save messages that have a MessageClass of REPORT.IPM.note.DR or REPORT.IPM.Note.Relayed
Diane Poremsky says
Since they all contain ipm.note, check for that in the message class name:
If instr(objItem.MessageClass, "IPM.Note") > 0 Then
Hola says
I suggest to add a line to account for long email titles resulting in too long filename:
If Len(sName) > 250 Then sName = Left(sName, 250) & ".msg"
Steve says
`Option Explicit
Public WithEvents objSentItems As Items
Public Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Dim objNS As Object
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Public Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
UserForm1.Show
‘ Works until here, opens UserForm 1 allows section and allows pressing of OKButton_Click() but then ‘gets errors shown below – see next to last sub, (1) objSentItems2_ItemAdd at end.
'The sub below, Public Sub objSentItems2_ItemAdd(ByVal Item As Object),
'is what the the Oneonta Button on UserForm1 will call to put in Oneonta Folder
'I put the whole thing in the user form. That didnt work so I took out the body and just left the call in
‘did not work either
End Sub
Public Sub objSentItems2_ItemAdd(ByVal Item As Object)
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
'sPath below works perfectly in your orignal macro
sPath = "\\HVSBS\PROJECTS\Oneonta\"
End Sub
Public 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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Private Sub OKButton_Click()
Dim objSentItems2_ItemAdd as Variant
objSentItems2_ItemAdd
‘(1) if I don’t define objSentItems2_ItemAdd, I get – Variable not Defined. If I do define it, I get – ‘Expected Sub, Function or Property.
‘Have tried making all the subs public and putting them in different modules but no luck.
‘Thanks for looking Diane!
End Sub
Private Sub ONEONTA_Click()
End
Diane Poremsky says
Ok... (I added the macro to the page as well).
This goes into a module - it can't be declared in Thisoutlooksession.
Public lstNum As Long
This goes into Thisoutlooksession
'Option ExplicitPublic WithEvents objSentItems As Items
Public Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Dim objNS As Object
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Public Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim dtDate As Date
Dim sName As String
UserForm1.Show
Select Case lstNum
Case -1
' -1 is what you want to use if nothing is selected
sPath = "C:\Users\slipstick\Documents\"
Case 0
sPath = "C:\Users\slipstick\Documents\Email Attach\"
Case 1
sPath = "C:\Users\slipstick\Documents\pics\"
Case 2
sPath = "C:\Users\slipstick\Documents\Balsam Lake\"
End Select
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End Sub
Public 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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
End Sub
This in the userform - I'm using a list box so the paths are all visible in the list box, rather than a combobox menu
Private Sub UserForm_Initialize()With ListBox1
.AddItem "Email Attach"
.AddItem "pics"
.AddItem "Balsam Lake"
End With
End Sub
Private Sub btnOK_Click()
lstNum = ListBox1.ListIndex
Unload Me
End Sub
Steve says
Hi Diane, how have your been? Fine I hope.
I have your 'Save messages as they are sent' macro working perfectly with your help. I'm trying to use a UserForm to open on sending an email that will give me a few choices of what folder to save the email in.
I don't have enough experience with optional arguments and private/public subs though to make it work. Would appreciate your thoughts here.
Code below with symptoms
Diane Poremsky says
I have a sample at https://www.slipstick.com/developer/code-samples/vba-userform-sample-select-list-templates/ that picks templates. The process is the same for file paths. (Sorry I missed this earlier.)
jitender singh says
Change Outlook 2007 Default message save format to msg instead of html
Diane Poremsky says
Yeah... but its about 3 or 4 steps more than you need with a macro. :)
shermaine says
Hi Diane,
Thank you for sharing these codes on your website, really appreciate it.
I am using the 'Pick the Folder Location' code and an error keeps popping up at the omail.SaveAs sPath & sname, olMSG line: 'Run-time error '13': Type mismatch'.
Basically the user would start from the default root folder (Trusted documents) and open subfolders (depending on the coname)/create new folders and the email would be saved in the folders.
I have tried changing Dim omail As Outlook.MailItem and olMSG As MailItem to Dim omail As Object and Dim olMSG as Object respectively and also tested whether the BrowseForFolder returns the full file path but these don't seem to be what's the problem here.
Would be great if you could take a look at my code and see if anything else could be causing the error?
---------------------------------------------------------------------------------------------------------
Option Explicit
Public Sub SaveMessageAsMsg()
'Dim oMail As Object
Dim omail As Outlook.MailItem
Dim objItem As Object
Dim dtDate As Date
Dim coname, sname, sPath, strfolderpath As String
Dim olMSG As MailItem
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("New Slate")
irow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
coname = Cells(irow - 1, 2)
strfolderpath = BrowseForFolder("C:\Users\engw\Documents\Trusted Documents\" & coname)
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set omail = objItem
sname = omail.Subject
sPath = strfolderpath & "\"
Debug.Print sPath & sname
MsgBox (sPath)
omail.SaveAs sPath & sname, olMSG
Cells(irow - 1, 13).Value = strfolderpath
End If
Next
End Sub
Thank you in advance Diane! :)
Diane Poremsky says
does it work if you remove coname from the path? strfolderpath = BrowseForFolder("C:\Users\engw\Documents\Trusted Documents\" & coname)
It can be picky with variables...
darren says
Hi Diane,
I am a new user to macro and VBA. My company wants to save the email in msg folder with the format of "YYMMDD-HHmm-SenderName-RecipientName-Subject.msg". Therefore, I was trying to use the code"Save Selected Email Message as .msg File". What I did was to go to "This outlookSession" and paste the code-> hit save -> restart outlook-> double click outlook session-> hit play, but it does not seem to work. By not working the code is not running at all
What I did was to hit "save as" at the email. I just wonder if there is a specific way to save the email to make the code works.
Diane Poremsky says
Do you get any error messages?
Did you change the macro security?
The macro for SaveMessageAsMsg doesn't need to be in thisoutlooksession - it is run manually, so you can put it in a new module. To make it easier, at a button for it to the ribbon - then you just need to click the button after selecting a message.
Nik says
Hello Diane,
how to modify the 1. code of "Save Selected Email Message as .msg File" to save the incoming e-mails via the rule (in the rule assistant via executing a script)?
The original code is with the line "For Each objItem In ActiveExplorer.Selection" which automatically prevents to select the correct e-mail. Witch line have I to mode to get the correct focus (= to process the e-mails that are filtered via the rule)?
Thanks
Nik
Diane Poremsky says
Response is at https://forums.slipstick.com/threads/95040-save-selected-email-message-as-msg-file/#post-349660
Nik says
perfect ;-)! Now the focus is set correct.
Miyamoto Kouta says
Hi, Diane!
I'm trying to use the code in "Save messages as they are sent" for Outlook 10 but doesn't work well.
Have something between O10 and O13 in this sense (of arguments or applications) in these code that could cause some trouble?
Diane Poremsky says
These macros should definitely work in all current versions. Are you getting any error messages? Remove error handling so you can see where it fails.
Anand says
Everything works great except one thing. This code is updated to avoid the read receipts messages. I want to save the read receipts too. Please let me know how could i do it? Urgent.
Diane Poremsky says
You need to also do reports message class (or, to do all, remove the if ipm.notes line AND change Dim oMail As Outlook.MailItem to Dim oMail As object.
Anand says
Followed as per your alternate option. Saves other emails as the same. But when it comes to read receipts, error '438' pops up. Please advice. Below is the edited module as per your comment.
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Object
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "123")
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, "-hh.nn.ss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = strFolderpath & ""
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
Next
End Sub
Diane Poremsky says
step through it and see which lines it fails on, or add msgbox oMail.Subject, oMail.ReceivedTime after Set oMail = objItem then step through it so you can see if the fields have values.
Anand says
This line has the error 438. Tried variations. Nothing working out.
dtDate = oMail.ReceivedTime
Diane Poremsky says
Is the message it fails on an email from someone or a read receipt or other non-message item?
Anand says
It fails on read receipt. Please provide a code which save all the items in the inbox. Please and thank you.
Diane Poremsky says
Try changing
Dim oMail As Outlook.MailItem
to
Dim oMail As Object
The macro at https://www.slipstick.com/developer/macro-move-aged-mail/#case shows another way to do it - you could use this method to get the date if using it in the filename.
Anand says
Tried everything :( Does not seem to work. Please see the below code and help me get this.
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Object
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "123")
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, "-hh.nn.ss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = strFolderpath & ""
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
Next
End Sub
Diane Poremsky says
Sorry for missing this earlier.
if you check your path, it's not valid:
enviro = CStr(Environ("USERPROFILE"))Debug.Print enviro & "123"
There is no slash after the username:
Returns
C:\Users\MaryContrary123use
enviro = CStr(Environ("USERPROFILE"))enviro = enviro & "\"
strFolderpath = BrowseForFolder(enviro & "123")
(if wordpress removes the slash, there is on in the double quotes. It will probably also screw up the 'and' sign)
mattgreenbean says
I have the
sSenderName = oMail.SenderName
included in my macro which stops the macro from working as a delivery/read receipt doesn't have a sender name. Is there a way to skip the sender name if there is none?
Diane Poremsky says
Sorry I missed this earlier - use an If statement:
if sSendername = "" then exit sub
you may want or need to test it earlier with
if oMail.SenderName = "" then exit sub
Kaustubh Thakur says
This is awesome! I've been looking for a similar code for a while! Many thanks!
Any chance of modifying the code so it automatically stores the .MSG file in the above "date and time" format every time I drag an email into a windows folder?
That would be an ideal solution for my team's needs. Thanks in advance and look forward to hearing back
Diane Poremsky says
Not that I am aware of using an Outlook macro. You'd need a utility that watched windows folders and could make the change.
Hudson says
this is working excellent , needed small changes in it. email is saving with what ever name that is in subject can this be more dynamic and save with "Memo Number" that has come in email body .
Rob J says
I too am having issues with oMail.SaveAs sPath & sName, olMSG generating an error. All Paths are correct, I have permission and can save there manually? I am using the above code as posted, OL2010
Diane Poremsky says
Are you trying to use a network path? Does it work with a local path? Does the path exist?
Rob J says
Hi Diane, and thank you for replying. I have tried both network and local. The path exists and I can drag messages into it. When I try to run, the error is RT error 287. App- defined or obj-defined error. During debug if I hover over the line that errors, sPath and sName both appear to be correct:
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 = "P:"
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = Left(oMail.Subject, 45)
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\OLDump"
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Diane Poremsky says
I think it is this - it needs an ending \
sPath = enviro & "\OLDump"
you are trying to save it in the root of P, named oldump20161018-105122.msg
Tip: to double check paths when errors come up do this: (or use debug.print and check the immediate window in the vba editor)
sPath = enviro & "\OLDump"
msgbox sPath & sName
oMail.SaveAs sPath & sName, olMSG
Rob J says
So I fixed those things, all looks good, but still errororing on that line. I've linked some screenshots .. https://goo.gl/photos/uXK8pBTpuDuLBUZCA
Diane Poremsky says
That is saving to A, which is typically the floppy disk. Do you have a drive at A: ?
Rob J says
Yes, I do. I use it for testing, but it is a local drive. I have also tried a folder on C and a network location. Same error each time.
Pierre-Luc says
Hello. I'm using the macro SaveMessageAsMsg().
Will there be a way to modify the macro in a manner where the .msg files will not include any attachment ? However attachements should NOT be deleted from the original e-mail.
Thank you
Diane Poremsky says
Try this modification -
Set oMail = objItem
Dim oAttachments As Attachments
Dim lngAttachmentCount As Long
Set oAttachments = oMail.Attachments
lngAttachmentCount = oAttachments.Count
' Loop through attachments until attachment count = 0.
While lngAttachmentCount > 0
oAttachments(1).Delete
lngAttachmentCount = oAttachments.Count
Wend
sName = oMail.Subject
Then at the end - discard the changes.
oMail.SaveAs sPath & sName, olMSG
oMail.Close olDiscard
End If
Next
It might look like the attachments are gone, but if you select another message then come back, the attachments will be there.
Nick says
Thank you so much for this code and the detailed explanation as to how to implement it. Everything worked as you described from creating the macro, browsing for a folder to signing it and creating a button on the toolbar. Very nicely done. I was using the “Save as” dialog in Outlook for months and today thought of getting an addin or something to automate the process. Lots of choices out there, but I’m a little frugal – so I was very happy to find your page. Now I’m trying to add a few extra lines of code to get it to remember the last path used before using the default. Haven’t had any success yet, but even so, this is so much better than before. Thanks again and have a great weekend!!
Diane Poremsky says
i haven't been able to make it work and don't think it's possible. sorry.
Nick says
So I stopped trying to get it to work using one button and just broke it up using two. At the end of the first SaveMessageAsMsg(), I end it with previousPath = sPath.
The just created another Public sub called SaveAnotherMessageAsMsg()
For errors, I used:
If previousPath = vbNullString Then
strFolderpath = BrowseForFolder(enviro & "\Documents\...")
Else
strFolderpath = BrowseForFolder(previousPath)
End If
So now I have two buttons on the ribbon instead of one. No big deal.
Thanks again...
Matt says
Hi Diane, Loved the Macro works beautifully.
At the moment I have the BrowseForFolder Function in my module section of VBA and the remaining in the ThisOutlookSession Section and it works great.
I am looking to duplicate the code essentially so that I can have two buttons that go to two different places on my computer (Current Jobs & Completed jobs).
In my eyes this should be fairly simple, all I should have to do is change the file directory for my duplicated code.
But I am struggling to get it to work as I don't know where to paste my new code? Do I put it under my current code in the ThisOutlookSession section? or do I need to make an additional ThisOutlookSession Section, if so how do I do that?
Thanks in Advance,
Matt.
Diane Poremsky says
Because the macro is not an automatic macro, it should be in a module, not thisoutlooksession. You don't need to copy the entire macro, you just need to make a new "stub" macro to pass the path string to the main macro.
If you want to hardcode the paths, remove this line:
strFolderpath = BrowseForFolder(enviro & "FILEDIRECTORY")
Move Dim strFolderpath As String so it's just under option explicit.
Change Public in the macro name to Private
Create a new macro that sets strFolderpath: (in the same module as SaveMessageAsMsg) - i always put the stub macro at the top of the page with the main macro under it - i think it's a little neater and easier to read but it really don't matter which is first.
Sub mynewmacro ()
strFolderpath = "c:\newpath"
SaveMessageAsMsg
End sub
Copy the macro above, change the name and file path.
Matt says
Diane,
Thanks very much for that, but I still seem to be having difficulty with this sorry, the below code is all in module1 but still seems to not be working, any help would be greatly appreciated.
`Option Explicit
Dim strFolderpath As String
Sub CurrentQuotes()
strFolderpath = "\\Current Quotes FILE DIRECTORY"
SaveMessageAsMsg
End Sub
Private 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("\\Current Jobs FILE DIRECTORY"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
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 = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), 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
Thanks,
Matt.
Diane Poremsky says
if you aren't using the user's folder path (C:\Users\diane), remove enviro = CStr(Environ("\\Current Jobs FILE DIRECTORY")) - it's a shortcut to the user path. It's not preventing the macro from running, since its not actually used but it would not work if you tried using it.
It's working here with a local folder. It's working with a network folder - i needed to be logged into the network computer before running the macro.
Matt says
Sorry Diane, I am still having isses. Specifically with the line "oMail.SaveAs sPath & sName, olMSG" it keeps telling me it has a run-time error '-2147287037 "the Operation Failed."
is it the wording of this line? I had no issues with this line prior.
Thanks in advance.
Diane Poremsky says
The macro worked here with a local path and a network path, so the code is good.
Add Debug.print sPath & sName
before that line and run the macro - look in the immediate window, is the path correct?
Does it work if you use a local path? There aren't too many things that can cause problems - if you are writing to a network drive, the drive needs to be open/logged in in windows.
Matt says
The path is correct - It is a network path (\\Server\Folder\Subfolder\Subfolder\Current Jobs) - for current jobs
(\\Server\Folder\Subfolder\Subfolder\Current Quotes) - for current quotes
If the network drive is the issue how is that resolved?
Diane Poremsky says
Do you need to enter a password to open those folders when you first log on the computer?
Try mapping the drives and use the mapped path - see if that works better.
Nick says
Sorry to get into this a little late. I had the same issue but with only some emails. The reason being that the path was too long. Too many characters in the subject line. It wouldn't even work with the normal Outlook Save As dialog. Strange thing is I added code to shorten the subject line to 45 characters - but that still didn't help. Probably need to find a way to capture the shortened name prior. But in any case, it works 99 percent of the time. So for those emails that have a long subject line, just use the normal Outlook Save As and shorten the subject line on a case-by-case.
Hope this helps...
Diane Poremsky says
How did you trim the subject? This should work -
sName = Left(oMail.Subject, 45)
or
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
sName = Left(sName, 45)
Jose Manuel says
Hi Diane,
Thanks a lot for your Macro.
I have a Retention Policy of 6 months and even It is not allow to move the emails to a local outlook folder.
So your makro is the only solution I found to save my emails.
The makro is very good. I would like to add the SENDER address or the TO address also to the name of the file.
My idea is to do two makros: one for the inbox folder and one for the sent folder.
So the idea is:
(SENT): Date + Hour + To address (just the first one) + Subject.
(INBOX): Date + Hour + SENDER address + Subject.
Do you think this could be possible?
Thanks
Diane Poremsky says
For To, yes, it will definitely work for sender's - use something like sName = oMail.Subject &"-" & omail.SenderName (or omail.senderaddress). To get the display name in the sent folder, use oMail.To. If you send to multiple people, it will include all names in the to field but not in the cc field. to avoid too long filenames, you may need to get just the first name using the recipients collection or trim the length of the string.
Lukasz says
Hi Diane,
I would like to ask you how can I combine your method of saving emails as they sent with my macro in access that after button click open new message in outlook and attach most recent file from my directory. Can I do everything in one access vba module in one button? It is important not to include it in outlook because I would like other people on their computers use this access file and be able to do that in one click in form. Really thank you in advance!
Diane Poremsky says
As long as you properly reference the outlook object model, you can control outlook using vba in other office products.
Doug says
Hi, I have set the "save messages as they are sent" to a module, but I cant get the Rules box to allow me to run it? This image may work:
How do I fix this?
Thanks,
Doug
Diane Poremsky says
Save messages as they are sent is an automatic rule - it runs every time you send a message. You need to restart outlook for it to start working.
Mike says
Hi Diane,
My apologies as I am new at using VBA and Macros. I was wondering where exactly I paste in the "BrowseForFolder" function code as I cannot seem to get this working so obviously I am just not putting it in the correct location within your "Pick the Folder Location" code.
Diane Poremsky says
it can either go at the end of the macro or you can add a module, rename it functions, and paste it there. (This makes it easier to share functions between multiple macros.)
Ray says
Hi Diane I was trying out your macros and I was wondering if you could help me with three things:
1. When an opened email is closed, is there a macro for a pop up to appear to save that email to a server and not the C Drive? I am thinking of being able to go select a folder on the server from the macro or maybe selecting from a previous list of folders? Then, when saved, being asked if you want that email to be deleted from your inbox, or if it has been saved already for the save pop up box to not appear.
2. Similar to above, when an email is sent, a pop up will appear to ask where that email is to be saved on the server, again, maybe selecting from a previous server folder list or being able to select a new destination. Then, when saved, being asked if you want that email to be deleted from your sent items. Again, if saved already, the pop up would not appear.
3. Finally (!), maybe wishful thinking here, but if an email is saved, then an icon would appear both on the email when opened or on the Inbox and Sent Items windows to let you know that the email has been saved already.
I am having awful trouble with many emails and tight 3 month restrictions on emails that I just cant handle. If you can assist with the above I would be very, very grateful.
Diane Poremsky says
1. As you are closing the message i think we can move it.
2. Yes.
3. Possibly. I'd need to look into it.
Ray says
Thanks Diane, any help would be appreciated.
Ray says
Diane, sorry to bother you but I wonder if you had some time to look at my macro query above? Just if you have some time, I would greatly appreciate it. Thanks. Ray.
Diane Poremsky says
On this? 3. Finally (!), maybe wishful thinking here, but if an email is saved, then an icon would appear both on the email when opened or on the Inbox and Sent Items windows to let you know that the email has been saved already.
Does it need to be an icon? Flags and Categories, or custom fields are easier to do and in 2 of those cases, work on most computers and devices (custom fields work in outlook windows desktop only). Plus, if you reply, the icon will either be replaced or not show that you replied.
To change the icon, you need to use a custom form with the different icon. It's actually not that much harder than a custom field https://www.slipstick.com/developer/vba-set-existing-contacts-custom-form/ - and sounds like a fun macro sample. (Just tried it - my custom icon isn't used when i change the message class :()
Steve says
Hi again Diane! Your macro was working fabulously for a month until today when I suddenly received an error. Unfortunately I didn't save the error message but when I debugged it, the following was highlighted: Item.SaveAs sPath & sName, olMSG.
After the initial fail, the macro doesn't work but I do not get the error message anymore.
Any ideas? (btw, enviro = CStr(Environ("USERPROFILE")) wasn't working so I texted it out and hard coded MyDocumnents)
Thanks again Diane, really appreciate what you do here.
Option Explicit
Private WithEvents objSentItems As Items
Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Dim objNS As Object
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
'enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = "\\HVSBS\RedirectedFolders\sunderhill\My Documents\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Diane Poremsky says
is this path valid? sPath = "\\HVSBS\RedirectedFolders\sunderhill\My Documents\"
Can you open it in explorer without logging in.
This: enviro = CStr(Environ("USERPROFILE"))
would add the path C:\users\steve\ - won't do you much good with a network path. You can delete it and all references to it.
Steve says
Yep, path valid. No login needed for the folder once I'm on the system. And it worked perfectly for a month and now appears to do nothing and no error messages except for that first time. And I'm searching every other folder I have access to to see if they're landing someplace else...
Any thoughts?
Diane Poremsky says
add msgbox "working" lines at the beginning of the macro and msgbox spath after the path is set - if the dialogs don't come up, its not working.
Steve says
The earth's core must've stopped spinning. Did as you suggested and both msgboxes appeared as they should have. But only the first time and the email wasn't saved. Tried several times and never got the message boxes again, or the saved email. Checked to be sure enable all macros on and it was. Even tried deleting the whole thing and starting from scratch with the enviro command knowing that wouldn't work. And it didn't, no error message, no msgbox and no saved email....
Appreciate your help but you've gone above and beyond.
Thanks.
Steve
Diane Poremsky says
You're using one that is an application start macro and an error will basically kill it - that's why it works once and never again. The problem is figuring out what is erroring. It's probably something with the network drive - does it work if you use a local drive? It might work if the drive is mapped.
Steve says
Core is rotating again, but have no idea why. Tried a local folder but was denied authority to save via the macro though I could save something directly.
Tried one last time by completely deleting and re-installing and now it works just fine again. Go figure.
Thanks so much for your help! May have to come back again when I try to modify to more closely match what I'll need.
Do you offer any products or consulting? Feel bad getting all this great help for free.
Diane Poremsky says
No products yet (I keep planning on an e-book, but never find time to work on it and i don't know why lol) but i do consulting via gotomeeting. Although not necessary, I won't turn down donations at paypal - my paypal address is diane at slipstick.
David says
Thank you, for your post of information!
Steve says
Diane - thanks so much for your work here, I really appreciate it! I can get the first two macros to work fine, but not Save Messages As They Are Sent.
After saving it in the vba editor, "Private WithEvents objSentItems As Items" is changed to red font but there's no error message. When I send items, they are sent as normal, but no copy in Documents and no error message.
Any thought?
Thanks again, Steve
Diane Poremsky says
Did you put it in ThisOutlookSession? Any macro that runs automatically needs to be there.
Steve says
Whoa - that did it, thanks!! Works famously. Added Dim objNS As Object because without it error message: Compile error: Variable not defined.
Really appreciate it Diane.
Sugat says
Hi Diane,
First of all i would like to thank you for making this site and helping people with the content.
I am trying to use your code to save all the outlook mails from inbox to a specified hard drive folder but getting a warning saying " A program is trying to automatically send mails on your behalf" do you wnna allow this ", below is the link for outlook warning message:
https://msdn.microsoft.com/en-us/library/office/aa168346(v=office.11).aspx
What code we need to modify to get rid of this warnign message and save all mails.msg to a hard drive location. Could you please help me with this.
Diane Poremsky says
What version of Outlook are you using? Do you have antivirus installed and updated? You shouldn't get that message with Outlook 2013 or 2016.
sugat says
I am using outlook 2010. and also after executing the code sometimes the macro stops at mItem.SaveAs StrFile, 3.
Not able to track the reason for it
Diane Poremsky says
Do a debug.print strFile so you can see the files and path - it sounds like there is a problem with the file name. Are you removing all illegal characters?
Devin says
Diane:
I've got the script working for myself in Outlook 2013. Now I want to modify it a bit so that instead of it saving the Outlook messages to a hard coded Windows Explorer directory, I want to have the code to have the Outlook messages saved to a directory that is named based on the Outlook folder the message resides in. So if the message is in the "Inbox" folder, the code will create a "Inbox" Explorer sub-directory and save messages there, or if the message is in the "Sent" folder, the code will create a "Sent" Explorer sub-directory and save messages there, or if the message is in a non-default Outlook folder like say "Messages from John", the code will create a "Messages from John" Explorer sub-directory and save messages there.
In order to do this when a Outlook message gets processed, the Outlook folder it resides in needs to get stored into a variable so that I can refer back to that variable when building the sub-directory. How do I get the value a message's Outlook folder?
Thank you
Diane Poremsky says
See https://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/ for a macro that contains most of what you need. You can get the parent folder name part gets the folder name or get the folder name by entry id if you are walking the folder list-
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
Luis Alberto says
Hola Diane,
Gracias por tu trabajo ta profesional e importante. Me ayudas indicando como ejecuto desde vba Excel tu macro: "Save Messages As They Are Sent". Tu macro "Save selected email message as .msg file" funciona muy bien.
Gracias,
Thank you for your professional and important ta work. Help me indicating your macro run from Excel vba: "Save Messages As They Are Sent". " Your selected email message as .msg file "Save macro" works very well. "
Diane Poremsky says
This is one way to call outlook from excel -
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
End If
Luis Alberto says
Diane,
Muchas gracias. No obstante, me ayudas con esto: cuando ejecuto lo siguiente "Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items" devuelve un cuadro emergente que dice: "se requiere un objeto".
Me ayudas cómo hago para encontrar o citar el objeto.
Muchas gracias,
Diane Poremsky says
It sounds like objNS is not set. Try changing objNS to Session or application and see if it works.
Luis Alberto says
Gracias por el procedimiento: Save Messages As They Are Sent
Deseo me ayude como ejecutar desde excel.
Gracias,
Thank you for the procedure: Save Messages As They Are Sent desire help me how to execute from excel.
Diane Poremsky says
This macro: https://www.slipstick.com/developer/create-appointments-spreadsheet-data/ shows how use an excel macro to work with the outlook object model.
Bryan says
Trying to use your as sent sub and it always says that objNS is not defined. How do I define it?
Diane Poremsky says
This line should be in with the Dim's
Set objNS = Application.GetNamespace("MAPI")
Maciej says
Hello,
Is it possible to implement this solution for calendar items (appointments)?
Thanks for any help
Diane Poremsky says
It can be changed. Change the dim to Dim oMail As Outlook.AppointmentItem - you'll also need to change the filename you save it as - receivedtime will error.
JAMES MATTHEW says
Hi Diane - I've been using this macro for years and love it. However the resulting .msg files are often copied over to a database system that limits filename lengths to 60 characters (including ".msg"). Is there a way to shorten the file to name to just 60 characters starting at the left? Many Thanks, JM.
Diane Poremsky says
if you are adding the date and it's always the same length, I would trim just sName (before .msg):
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & left(sName, 45) & ".msg"
otherwise, put the entire part before the extension inside left()
Doug says
Hi, these are terrific routines. Thanks very much!
One issue is that I cannot get "Save messages as they are sent" to work simultaneously with your "Run as a script rule" from your page using the ItemAdd method?
Would love it if you could solve this one! i've tried everything (complete VBA noob!).
Thanks again.
Diane Poremsky says
You can't use a run a script rule to save sent messages - you need to use an itemadd macro and watch the sent folder.
Which macro won't work with it? As long as it's looking at the sent folder and everything is named correctly, it should work, although sent items are missing some properties that are on incoming mail (where run a script works).
Nancy Revelle says
Hi, I want to set up a macro in Outlook 2010 that saves the email I'm working on to a template (.oft) in the default template directory to the same file (overwriting). I do this several times a day and it would be so nice to have it automated. I can't seem to find how to do this specifically. Thank you!! Nancy
Bruce says
Hi
Is there any way to open a dialog box from excel that will allow you to select a mail item from Outlook and then export that selected mail item to .msg file in my documents folder.
Thanks
Bruce
Diane Poremsky says
You can; I don't have any code samples but basically, you need to load the outlook object model, read the inbox and load it into a list control in a userfrom and get the selections index number.
Mike says
This is great but if I select too many emails to move I always get an out of memory error. Any way to fix that?
Los says
I am having the same issue. Not enough resources and I get an error, when i debug code and variable values look ok.
Diane Poremsky says
Try moving the Dim omail line into the If loop and then set it to nothing it at the end.
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Dim oMail As Outlook.MailItem
Set oMail = objItem
--snip--
Set oMail = Nothing
End If
Christine E. says
Hello,
I need to setup a script and/or a macro to automatically run when I receive an outlook email with a .pdf attachment which has the word "image" in the name of the attachment. I need to have the file(s) automatically copied to K\IPOS\SF - SEA Reading File\2015\10 - 15\. I also need to have the same file copied to K\IPOS\Program Review\SharePoint\ERM\. How do I go about doing this with the code you have out there. I have tried to modify some of the code to perform this operation and I have had may different errors.
Can you assist me?
Diane Poremsky says
The macro on this page works with the message, you want the one at https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/ -
To save into two locations, set the locations:
' Set the Attachment folder.
strFolderpath = "\\K\IPOS\SF - SEA Reading File\2015\10 - 15\"
strFolderpath2 = "\\K\IPOS\Program Review\SharePoint\ERM\"
get the pdf:
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).filename
' This code looks at the last 4 characters in a filename
sFileType = LCase$(Right$(strFile, 4))
if sFiletype = ".pdf" then
if instr(strfile, "image") then
use these lines to save:
strFile = strFolderpath & strFile
objAttachments.Item(i).SaveAsFile strFile
strFile = strFolderpath2 & strFile
objAttachments.Item(i).SaveAsFile strFile
end if
end if
Ralf says
Thanks a lot for this great collection. You made my day!
Finally I found an easy to use alternative to ship around the .pst file which is restricted where I am working.
Ralf
Chieri Thompson says
Nevermind! I think i got it!
Sub Test()
Dim oMail As Outlook.MailItem
Dim oItem As Object
Dim strTemp As String
Dim strFilenum As Variant
Dim sPath As String
Dim sName As String
Set oItem = ActiveInspector.CurrentItem
strFilenum = InputBox("If all/one Exists click X in Field to proceed. ", "ADD Design #, PO #, SO #")
If strFilenum = False Then Exit Sub
If strFilenum = "" Then Exit Sub
On Error Resume Next
strTemp = "[" & strFilenum & "] " & oItem.Subject
Set oMail = oItem
oItem.Subject = strTemp
'oItem.Save
sName = "[" & strFilenum & "] " & oItem.Subject & sName & ".msg"
'ReplaceCharsForFileName sName, "-"
sPath = "C:\Users\cthompson\Desktop\Downloaded Artwork\"
'sPath = "\\ac-fs1\NetVol\LOGO DEPT\APPROVAL LETTERS\"
oMail.SaveAs sPath & sName, olMSG
End Sub
Chieri Thompson says
Okay, So I realize this post is older. But I have been trying to Utilize an "input box" to add data and use your save msg file to a drive. To Elaborate. Add data to subject line using Input box, save data in subject then save to drive. I am real close but I cannot pin point why its replacing my subject with the new subject and not keeping "date + original sub"
Sub AddSaveTest()
Dim oMail As Outlook.MailItem
Dim oItem As Object
Dim sPath As String
Dim sName As String
Dim addSub As Variant
'On Error Resume Next
Set oItem = ActiveInspector.CurrentItem
'Set oItem = ActiveExplorer.Selection
addSub = InputBox("Add Design Number")
If addSub = False Then Exit Sub
If addSub = "" Then Exit Sub
On Error Resume Next
Set oMail = oItem
oItem.Subject = sName
oItem.Save '
'
'
'For Each oItem In ActiveExplorer.Selection
'If oItem.MessageClass = "IPM.Note" Then
'
'
''sName = oMail.Subject
sName = "[" & addSub & "] " & oItem.Subject & sName & ".msg"
ReplaceCharsForFileName sName, "-"
sPath = "C:\Users\cthompson\Desktop\Downloaded Artwork\"
oMail.SaveAs sPath & sName, olMSG
'End If
'Next
End Sub
Nick says
I need some help with this macro...I'm having a problem if the email has the same subject line, it just gets overwritten. So if I were to select multiple emails and use the macro and a few had the same subject line, it would overwrite them i.e. I use it on 8 emails and it only saves 6, because 2 got overwritten as it had the same subject line. Is there a remedy for this? Thank you in advance.
Diane Poremsky says
Either add the received time to the subject or add a code. Actually this:
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
uses the date and time so it shouldn't overwrite. If you removed the date & time, you can add a number:
If you are saving a selection, you can count the selection and add the count the subject.
at the beginning:
lcount = 1
' snipped code
sName = sName & lcount & ".msg"
lcount = lcount + 1
MIke O'Reilly says
I came on this today. It is excellent. I have added it with a button to put any highlighted email into a specific folder. That folder is a PaperPort folder where I am now storing all my files. t works perfectly thank you so much.
Sameer says
Hey Diane,
I'm trying to create a Macro to open the saved mails (.msg) which are saved in a folder and then copy the date and time of receiving the the mail.
Can we have it like an excel sheet
Subject line of mail - date received - time received
incase of repetition of mail,
Subject line of mail - date received - time received, date received, time received and so on
Your help is very much appreciated on this.
Thanks in advance.
Diane Poremsky says
In a text file? Yes, as long as you use tab or comma delimiters. I have a sample here - https://www.slipstick.com/developer/code-samples/save-email-message-text-file/ - that does line feeds but you can change the vbcrlf to vbtab or "," &. If you use commas and the text has a comma, you'll need to wrap the fields in quotes (add chr(34) &)
Anand says
Hi Diane - thank you for your hard work! I was able to set up the macro to save messages along with BroweseForFolder function. Only issue I am facing now is saving multiple message to the same folder using BrowseForFolder function. The file location prompt comes up for each individual message. Is there a way to select multiple message and save them to a specific folder using BrowseForFolder function? Please let me know. Thanks
Diane Poremsky says
You'd put the browse for folder stuff before the for each... line. This defaults to documents but uses
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\documents\")
For Each objItem In ActiveExplorer.Selection
Change the spath to to this to set the path at the end:
sPath = strFolderpath & "\"
Alan McGowan says
I'm trying to use the code to save messages as they are sent. I have changed enviro = "c:\Inbox" but when I send an email it is not being saved into c:\Inbox
Diane Poremsky says
Try changing this line:
sPath = enviro & "\Documents\"
to sPath = "C:\Inbox\"
Alan McGowan says
The problem seems to be becuase I have a Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) macro also in the ThisOutlookSession. If I delete this code it works fine but if I leave it in the message isn't saved.
Diane Poremsky says
Yeah, you can only have one itemsend - you can combine them and use if statements to apply the code to certain messages.
Mark says
I'm running it from Excel. I think i changed the reference, but by the lack of knowles of VBA i'm not sure.
The error on "Dim oMail As Outlook.MailItem" is still there.
Would you be so kind the check the code below and make some suggestions for improvement?
The code i have so far is:
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
If objitem.MessageClass = "IPM.Note" Then
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
End If
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Mark says
Hi,
My intention is the select from a excelsheet a selection of email messages in Outlook and then save them on a directory like C:\data\....
So your code for "Save selected email message as .msg file" seems to be the right one for my assignment. Unfortunaly i get a few error messages with the code
• Dim oMail As Outlook.MailItem
I get a compile error. A Datatype is not difined.
• For Each objitem In ActiveExplorer.Selection
I get a compile error. A variable is not difined.
I hope you can help me.
Diane Poremsky says
Are you running the macro in outlook or excel? The objects are declared - but if you run it from excel, you need to reference the outlook object model.
Dim oMail As Outlook.MailItem
Dim objItem As Object
John says
"Dim oMail As Object" did the trick. Much thanks, Diane. If I had an adblocker, I'd whitelist your site ;-)
John says
Ugh.. note that my sPath value was removed when I submitted my comment. The path is not my issue.
John says
I use a version of this macro with very satisfactory results. But now, I want to be able to save Lync Conversations (IPM.Note.Microsoft.Conversation) and meeting invites (IPM.Schedule.Meeting.Request). The latter often contain large presentation attachments.
When I attempt my macro (below) on these Message Classes, nothing is saved in my designated "sPath". No errors are thrown.
Is this because "oMail" is ONLY for IPM.Note classes? Can I simply insert a few extra lines at the top to accomodate these additional classes referenced above? If so, what do I need to add?
----
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.SenderName & " - " & oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
sPath = ""
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)
End Sub
Diane Poremsky says
Try changing Dim oMail As Outlook.MailItem to
Dim oMail As Object
(Yes, it's probably because of the class.)
Adam says
My most-functional code:
Option ExplicitPublic 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
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder
' get the function at http://slipstick.me/u1a2d
strFolderpath = BrowseForFolder("H:\Outlook Files\Manual archives")
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
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 = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
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
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, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, vbTab, "_")
End Sub
phillfri says
Just a heads up. Recently needed to develop code along these lines for an Excel/Outlook interface and ran into two "gotchas". [1] VBA code can change environment strings within VBA itself and the result one gets from using the environ command afterwards will be the changed string - not the original environment string. Probably safer to use the shell object to get the USERPROFILE. [2] If you are using OneDrive for storage the USERPROFILE environment variable string being returned contains an https:\\ url address rather than a local drive. Code will need to be changed to convert that into a path string that VBA will recognize.
Diane Poremsky says
Do you have a code sample that exhibits these behaviors?
Paul says
This code does not seem to work on messages which have an attachment.
I've been looking for a way to add this ability but with no luck.
Does anyone have a solution to this?
Thanks
Paul
Diane Poremsky says
What happens when you try? It should work on all messages - when you save the msg file, the attachment is wrapped within the message. If you want the attachment saved separately, it uses different code.
Adam says
I am having the same issue. The code does not seem to take action on messages having attachments. After running the macro on a standard message, the cursor icon changes to the 'working/thinking' icon and the message appears in the designated folder. However, this process does not happen with messages containing attachments (to include digitally signed messages, encrypted messages, meeting invites, out-of-office replies).
I have tried:
Changing *Dim oMail As Object
Changing *If objItem.MessageClass = "IPM" Then
Including *sName = Replace(sName, vbTab, "_"
Changing and running on an appointment message *If objItem.MessageClass = "IPM.Appointment" Then
Getting desperate, didn't work on any message type *If objItem.MessageClass = "IPM" & "*" Then
Diane Poremsky says
>> digitally signed messages, encrypted messages, meeting invites, out-of-office replies
Macros will struggle with signed and encrypted - it can't open them.
Invites and OOF responses are a problem because they aren't mail...
Paul says
It produces a run-time error stating the operation failed
-2147286788 (800300fc) and when clicking debug points to
oMail.SaveAs sPath & sName, olMSG
Paul says
Hi I have resolved the issue, what it was in some instances there may be a tab delimiter in the subject if it has say been copied from excel.
So the invalid character of vbtab needs to be included
sName = Replace(sName, vbTab, "_")
Janice says
GREAT! thanks :)
Tomas Bouska says
Hi all,
I changed this part of code to fight the path length limitation of 260 characters:
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName
sPath = enviro & "\Documents\.Private\"
Debug.Print sPath & sName
sPath = Left(sPath & sName, 255) & ".msg"
oMail.SaveAs sPath, olMSG
Also I got an error when saving a message with TAB in the subject, so I extended the conversion routine with this line: sName = Replace(sName, Chr(9), sChr)
Cheers, Tomas
Janice says
Dianne -
I love this macro! but...it seems that if there are too many addresses in the 'TO' field I get an error. Is there a way to limit the characters of the TO field so that I don't get an error?
thanks!
Diane Poremsky says
See Tomas' change.
Roberto says
Hello When I test the macro I get a compile error on Option Explicit Public Sub SaveMessageAsMsg()
Are there any fixes?
I am using Outlook 2010 on Windows 7
Diane Poremsky says
is this all one line? Option Explicit Public Sub SaveMessageAsMsg()
it should be two lines:
Option Explicit
Public Sub SaveMessageAsMsg()
Emmanuel Morin says
Diane, I was searching for that for so long, I am pleased. But can we get it a little bit further? Here what I am looking for: Select the mail that I want to save, then drag-and-drop it to the destination Windows folder using a right clic of the mouse. Actually Windows provide a sub-menu with "Copy", "Move", "Cancel" options. Can we have an third option pointing the macro? Thanks
Diane Poremsky says
As far as I know, no, you can't. At least, not easily - it's doable (as utilities add to it) but I don't have code samples and it might require a compiled dll, rather than a macro.
Brett says
Hi Diane. I was wondering if you have had a chance to review this? Again if it is not possible that is fine.
Diane Poremsky says
No, not yet. I've been swamped the last couple of weeks. Sorry.
Brett says
The only edits to the macros was from your comments above in regards to adding code for have the ability to select the file the message is to be stored in. I replaced the sPath line with StrFolderPath = BrowseForFolder ("C:\Users\myusername\documents\")
sPath = StrFolderPath & "\"and defined the variable Dim StrFolderPath as String.
When I use the BrowseForFolder listed in you article "How to use Windows filepaths in a macro", this macro works fine.
However when I add the SaveAllEmails_ProcessAllSubfolders code I get the “Compile error: Ambiguous name detected“ due to multiple functions with the same name. So by removing the one from "How to use Windows filepaths in a macro" that is when I am getting a Run-time error' - 2147287035 (80030005)'" You don't have appropriate permission to perform this operation . I can select the folder, but when I hit OK I get the run-time error.
It is like the BrowseForFolder function in the SaveAllEmails_ProcessAllSubfolders won't work with SaveMessageAsMsg but works on it's own just fine and vice versa.
Sorry I guess I am looking for the best of both worlds and perhaps it is just not possible.
Diane Poremsky says
Ah, ok. so the problem is with the browseforfolder code - I'm guessing an object is not referenced the same in both codes, but will check.
Brett says
Dianne, thank you for the quick response. I am saving this to an existing folder that I have full permissions for. The thing I can't figure out is if I temporarily remove the the code for SaveAllEmails_ProcessAllSubfolders from my system (adding back in the BrowseforFolder code), the SaveMessageAsMsg code works flawlessly and I can save to any folder. I also have no issues using the SaveAllEmails_ProcessAllSubfolders with both codes on my system, it seems to work fine. I am not too sure what it is and not being overly familiar with VBA, I am stumped. These are the only two modules I have on my system and separately they seem to work fine but together they the SaveMessageAsMsg code seems to lock up. I know it is awfully tough to analyze things over a forum, so I thank you for your patience with me.
Diane Poremsky says
Did you edit the macros? They both work fine here, even when entered in the same module.
Brett says
Dianne, further to this post, when I debug the SaveMessageAsMsg code it goes directly to the mail.SaveAs sPath & sName, 01MSG. I should have included this originally, sorry.
Thanks Dianne, worked like a charm and I can now select the appropriate folder. Another issue arose however where I am getting a Run-time error' - 2147287035 (80030005)'" You don't have appropriate permission to perform this operation so I cannot save the email message. It worked flawlessly before I loaded the SaveAllEmails_ProcessAllSubfolders code and if I remove that code and just run with the SaveMessageAsMsg code it once again works without any issues. Any thoughts here as I would very much like to utilize both codes.
Diane Poremsky says
do the subfolders you are saving messages to exist? If not, you need to create the folder.
Something like this -
If Len(Dir("c:\" & strNewFolderName, vbDirectory)) = 0 Then
MkDir ("c:\" & strNewFolderName)
End If
Brett says
Dianne, thank you for this wonderful code. I am also new at VBA so I have utilized both the code above (with the BrowseForFolder option) and also your SaveAllEmails_ProcessAllSubfolders code to save entire folders of email to my hard drive. Upon loading the second code though I am getting an error on the SaveMessageAsMsg code stating “Compile error: Ambiguous name detected“ highlighting the BrowseForFolder on the StrFolderPath line. Any thoughts as to why the SaveMessageAsMsg has stopped working?
Diane Poremsky says
you only need one copy of browseforfolder - all macros can use the one copy. What the error is telling you is that you are using a macro name twice - you need unique names for all macros and functions.
Winfred says
I need to skip all invitation manually, which is painful as I have many... There is no error after 130 and it stop without any notification... i just accidentally realize it as the folder size seems small comparing to the email size that I save...
Diane Poremsky says
Replace
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
Set oMail = objItem
with
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
if objItem.messageclass = "IPM.Note" then
Set oMail = objItem
then before the Next at the end, add End If.
That will only save messages.
Diane Poremsky says
As an FYI, i updated the macro tonight to check message class.
Winfred says
This is good; however, I identified a limitation where it will stop when the quantity of mail is more than 130 or have some calendar invitation...
Diane Poremsky says
Yeah, invites will stop it unless you use an if statement to skip non-mail items. It should go beyond 130 though. Does it error or just stop?
Winfred Tam says
What if I want to add the name sending the email after the date & time at the file name, what can I do?
Diane Poremsky says
This is what we have now:
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
To add the sender name, you need to add
dim strSender as string ' at top with other dim's
strSender = omail.sendername
it will also need invalid filename characters removed - so i'd order it this way:
sName = oMail.Subject
strSender = omail.sendername
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & "-" & strSender & ".msg"
ReplaceCharsForFileName sName, "_"
Michelle White says
I am looking for a code to save my email as "date-time-from-to-subject
I have this but without the From and Received. Are you able to help fix this?
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, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & "-18259-U200.C.00524-" & sName & ".msg"
sPath = enviro & "\Documents\001 New Emails to File\"
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)
End Sub
Diane Poremsky says
do you want the sender email address or display name? You'd use something like this - .to might not work for incoming mail and could be goofy if there is more than one recipient on the message
sName = omail.to & "-" & omail.sendername & "-" & oMail.Subject
Jack Hill says
Disregard my previous comments regarding the problem. I think I finally figured out the problem. Most related to poor transcription from the web page on my part. I am having one issue though. Seems that if there is a meeting notice in the list of emails to copy, the macro fails with a runtime erro = '13'. If I skip those, it seems to run OK. Where can I find a list of the Office object names? I'd like to add From and To fields to the file name format.
Diane Poremsky says
if you want to save meetings too, change Dim oMail As Outlook.MailItem to Dim oMail As Object.
To skip non-mail, use
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Set oMail = objItem
' code
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
end if
Next
Open the object model - F2 while in the vba editor or use the View menu > object model. MSDN has helpful information about objects, once you know the object name.
from field is sendername, To field is part of the recipients collection and could contain multiple entries. This will get a string containing the sender's display name.
Dim objVariant As Variant
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
Jack Hill says
Last line of first paragraph should be: I get a compile error: Sub or Funciton not defined.
Jack HIll says
I am new to working with VBA code, but looking for a way of saving to hard disk Outlook 2013 emails in .msg format. This looks great, but I am having difficulty with one line in the example for saving as a .msg file. It is not clear if I put the code in a new Module 1 by right clicking on ThisOutlookSession. On the line ReplaceCharsForFileName sName, "_", I cge ta comple error: Sub or Function not defined.
My objective is to use the macro against specific folders in Outlook (basically Search Folders with specific date ranges) and export them a folder on an external hard drive for archive purposes. Any assistance would be appreciated.
Diane Poremsky says
Although you figured it out before I got to the question, for the benefit of others this: "On the line ReplaceCharsForFileName sName, "_", I get a compile error: Sub or Function not defined."
Usually means the function is missing.
John Durbin says
Why is the saved .msg file an un-sent .msg file? Is there a way to fix that so that the sent version of the file is saved?
Diane Poremsky says
The itemsend macro saves before it's sent, so it saves a draft. I'll change it so it watches the sent folder.
Diane Poremsky says
As an FYI, I updated the macro and changed it to watch the sent folder.
dave says
This is a great tool! Can the saved file name also include sender (from) of the email [and possibly the recipient? or the first named recipient?]. {We are trying to capture- sender, recipient & subject of email in the saved .msg on our network.} If adding sender (and possibly recipient) can be added, where would this additional string of code go in your scrip? Using Outlook 2010. Thanks for any suggestions.
Diane Poremsky says
Yes, it can. omail.sendername (or omail.sender if sendername doesn't work with your account type) and omail.to. omail.to gets all of the names in the to field. You can do it something like this:
sName = oMail.Subject & "-" & oMail.Sender & "-" & oMail.To
mike says
need to check for:
sName = Replace(sName, Chr(39), "")
sName = Replace(sName, "*", "")
James L. says
This script has totally saved me! Thank you so much!
Only thing that needs to be changed about it is that it doesn't strip any asterisks from file names, so I had to add that to the code. Otherwise it is perfect!
Thomas says
Hi Diane,
for the normal email (oMail), it works great. I have some problem with the oReps. In Outlook 2003 this was also working fine, but in Outlook 2010 the macro won't save any mail with TypeName(objItem) "MailItem", as msg.
Diane Poremsky says
It works in 2013, so it should work in 2010. do you get any error messages?
Kurt S says
If I understand the code correctly, I would use the original code to save the email as a .msg file, then open it and apply the properties to it.
Thank you so much. This will make managing my emails so much easier.
Diane Poremsky says
Right, you need to save the msg then update the properties. It can all be in one macro, but it needs to be in that order.
Kurt S says
This is GREAT.
One thing that would really help me is to populate the file attribute/properties. Like put the subject in the Subject Property, etc. That way I can sort easily in folder view, rather than having to pull it back into Outlook sort and search.
If that cant be done, can you move the "RE: " from the front of the subject to the end, to sort alphabetically and keep threads together?
Thanks!!
Diane Poremsky says
It can be done using FSO - you might be able to guess at some of the property names but I'll see if i can find a list of them
Set objFile = CreateObject("DSOFile.OleDocumentProperties")
objFile.Open("C:\file\my.msg")
objFile.SummaryProperties.Subject = "This is the subject"
objFile.Save
set objFile = Nothing
anasa says
Hi Diane - Did you ever find more of the FSO properties? I'm interested in this as well but I don't see any other comments on how to do so (i.e. setting Subject, Sender, etc)
Also would this (objFile) be in place of the oMail object and instead of
oMail.SaveAs sPath & sName
we would just do
objFile.SaveAs sPath & sName (assuming there is a similar function for that object type)
Thanks!!
Diane Poremsky says
no, i haven't found any - at least not for general windows files. I've worked with file properties in word docs (and set them using word macros).
James Matthew says
The folder does exist in that path. I finally got it to work using the complete path C:\Users\username\........". Is there a change I can make in the code to include calendar items when they're selected as well? Thanks again.
Diane Poremsky says
Hmm. Interesting. It should have worked with enviro. Oh well. If you change Dim oMail As Outlook.MailItem to Dim oMail As Object it should work for any items type.
James Matthew says
Diane - any idea why this works fine on Outlook 2010 and doesn't work for me using Outlook 2007? Both are running Windows 7. With OL 2007, I keep getting the error, "Run-time error '-2147287037 (80030003)': The operation failed.
When I run Debug, it points to this line: oMail.SaveAs sPath & sName, olMSG.
My sPath is sPath = enviro & "DesktopOutlook".
The Immediate window shows DesktopOutlook20140318-164025-RE_ Investigative Report.msg. That turns out to be the first line of the selection but it never copies to the DesktopOutlook folder.
Thanks so much for your help.
Diane Poremsky says
Does that folder exist at that path? Could your antivirus be blocking it from writing to that path? Because it's on the desktop, there may be a security setting that is preventing automation to that folder. Test it to the My Documents folder to verify the code is not being blocked.
Stephen says
Hi,
Thank you for making this code available, is very good and working well for us.
Is it possible to add something to the code so that the mail item is permanently deleted rather than moved to the deleted items folder ?
Regards
Diane Poremsky says
You'd need to watch the deleted items folder and delete it again, VBA doesn't have a permanently delete option.
Harald N says
Hi Diane Poremsky
I am also beginner at this and hoping very much for your help. I would like to have as Caroline Marie to have "a dialog box [that] appears and prompts the user to choose where to save the email" I have tried to ad the function BrowseForFolder and it prompts okay but does not save the file. I have read the comments but can't make it Work. Can you help is it wrong to implement the function ?
Hope you will help me, thanks.
Regards
Harald
Diane Poremsky says
Sorry for taking so long to reply, I was swamped and needed some free time to look into it. (And once I made the time, it was a 30 second fix.:( )
The macro is not adding the last / to the path it's being saved, but in this case, as a file named TestFolder...
C:\Users\Diane\Documents\TestFolder20140414-025147...
If you change these lines to include the last slash, it will work.
Debug.Print sPath & "\" & sName
oMail.SaveAs sPath & "\" & sName, olMSG
The Debug.Print line writes the path to the Immediate windows, which you can turn on from the View window or using Ctrl+G.
Mark says
Diane, I am trying to use this macro to save files to My Documents on my C: Drive. I added a folder titled MailSave and replaced "\Documents\" with "\My Documents\MailSave\", but it didn't seem to work. Am I missing another change in your awesome macro? Thanks!
Diane Poremsky says
Do you get any errors? Add msgbox "working" right after the set omail line and replace debug.print with msgbox - this will kick up a dialog when the macro hits that line. It will tell us if its running. If its not running, did you check your macro security setting?
Javier says
Hi Diane,
I tried to send a reply in more than three times, and does not work, any reason...?
regards,
Javier
Diane Poremsky says
A reply here? We were working on a server update. If you mean an outlook message, did you get any error messages?
Fred says
Diane,
Is there a way to have your code run from the rules wizard? I opened VBA from outlook, added a module and pasted your script. When i go to the rules manager i create a new rule and use the "Run a Script" as the action but when the pop up window appears to select the script to run its blank.
any insight would be appreciated,
Fred
Diane Poremsky says
If it's properly formatted for a script, it should work. Try changing
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
to
Public Sub SaveMessageAsMsg(oMail As Outlook.MailItem)
and you need to remove the selection bits -
For Each objItem In ActiveExplorer.Selection
Set oMail = objItem
and Next at the end.
Caroline Marie says
Hi Diane,
It works perfectly, thanks! :)
However, I forgot to mention something important, when I asked for "a dialog box [that] appears and prompts the user to choose where to save the email".
My previous VBA code (Windows XP) asked the user where to save the file and we could change the filename before saving it (example: https://i44.tinypic.com/2wpmtqg.jpg).
We have clients who love (a little too much...) writing long subjects, so saving the whole e-mail subject (as of now) may be a problem (especially because our paths on our network are also awfully long). And my coworkers told me that they often changed the filename before saving their emails with the previous macro.
Huge thanks in advance!
Diane Poremsky says
It can be tweaked to shorten the file name to nn number of characters. :)
Outlook doesn't have a file dialog so you need to use Word's dialog or the windows common file dialog. I had this code sample handy - https://www.slipstick.com/code-samples/dirty-saveas-dialog.txt. Using word's dialog adds .docx to the filename but the code removes it and saves as msg format - that is why i call it a dirty saveas. :)
Mike Gorman says
Diane - Love this site. don't suppose there is a way to alter this slightly so you just set the filepath once at the start for all the selected messages? Al though dirty, this saveas dialog is more friendly than the BrowseForFolder function :)
Diane Poremsky says
You can add a counter and if statement -
add your Dim's
Dim newPath As String
Dim showDialog As Variant
Dim lenPath As Long
after enviro =, add these two lines:
defaultPath = enviro & "\Documents\"
showDialog = 1
replace the block from If dlgSaveAs.InitialFileName to sPath = with this block:
dlgSaveAs.InitialFileName = defaultPath & sName
If showDialog = 1 Then
If dlgSaveAs.Show = -1 Then
strFolderpath = dlgSaveAs.SelectedItems(1)
End If
'remove .docx from file name
sPath = Left(strFolderpath, Len(strFolderpath) - 5)
lenPath = InStrRev(strFolderpath, "\")
newPath = Left(strFolderpath, lenPath)
Debug.Print lenPath, newPath
Else
sPath = newPath & sName
End If
then right before Next, add
showDialog = showDialog + 1
this brings up the word dialog on the first message and uses that path for the remaining messages in the selection.
Mike Gorman says
Thanks again! having some issues with the dialog box appearing behind Outlook, making it look like it has crashed. sometimes i can alt-tab to it but that doesnt always work...any idea how to guarantee it appears on the top?
Diane Poremsky says
No, i don't. Does it happen all the time or just sometimes?
Mike Gorman says
Just sometimes - i am trying to see if there is a trend but can't figure it out
Caroline Marie says
Hi Diane,
Is there a way that, instead of hardcoding the path, a dialog box appears and prompts the user to choose where to save the email?
I used to have a macro that would do so (using the SAFRCFileDlg.dll), but it doesn't work under Windows 7.
Thanks!
Diane Poremsky says
See How to use Windows filepaths in a macro - you'll need the function from that page and replace spath line with something like this
strFolderpath = BrowseForFolder("C:\Users\username\documents\")
sPath = strFolderpath & "\"
Javier says
It is possible a variation of the code to loop through all the sub folders that are in the inbox, and save all messages to local disk with the name of each folder, for example:
\user\inbox\ ---> all messages that are in my inbox
\user\inbox\ client 1 ---> all messages that are in my folder client 1 (sub folder of Inbox),
and so on.
Also save sent items.
Any idea how I can modify the code to do this.
Thanks in advance.
Best regards,
Javier
Diane Poremsky says
That is possible to do - this macro should do it for you. Saving All Messages to the Hard Drive Using VBA/
James Matthews says
Diane - I keep getting an error message and the debug is showing a problem with the line: oMail.SaveAs sPath & sName, olMSG. When I scroll over "olMSG", I'm seeing olMSG = 3. Also, does it matter if the VBA is in Module1 or in ThisOutlookSession? Thank you.
Diane Poremsky says
This macro works in either module1 (well, any module) or in ThisOutlookSession, although a module is recommended.
olMsg is a constant, value 3 so that is normal too.
What does the error message say?
Add
debug.print sPath & sName
right about the SaveAs line that fails then show the immediate window (ctrl+g) - is the path correct?
Anthony Stedman says
Hi Diane
Thank you for coming back to me. You are an incredibly generous person with your time and I appreciate that.
We all use the L drive in the office.
I will fiddle with this code as per your suggestion.
Cheers again. I don't know how to thank you for your time running this site. It has been invaluable to me,...
A
Anthony Stedman says
Hi Diane,
I have gone with the vanilla approach in the absence of a better understanding of VBA... I will need to spend some more time on this for my sake (And perhaps for yours as well :-)
I would love to be able to tell Outlook to save this email to a specific location on our server so that we can extend the same code to all 6 machines in the office.
I saw this code example on one of your pages but have no idea how to insert same into the context of the larger string I was referring to earlier...
Note: this function will work in any Office application, it is not specific to Outlook. (Actually, it's not specific to Office either, it's a general VB function.)
Dim strFolderpath as String
strFolderpath = "C:\OLAttachments\"
Or use this to save to a folder using the user's profile in the path (example, C:\Users\Diane\)
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = enviro & "\OLAttachments\"
My file path to the server is L:\Client Filing\Email Filing
Any assistance on this would be truly appreciated.
Cheers, Anthony
Diane Poremsky says
Does everyone use L: for the file share? If not, using the server name \\FileServer\client\filing would be universal.
The important line is the one that sets the strFolderpath - how you set that path is up to you.
you can use a hardcoded path:
strFolderpath = "\\filesserver\path\OLAttachments\"
or
strFolderpath = "L:\Client Filing\Email Filing\"
Anthony Stedman says
Hi Diane,
Thank you for putting this code up. I am a newbie at this and am having some difficulty in running the code...
I have followed your instructions to the letter but have made a change to the save path. When I run the code, I dont get a result and in fact, get a run error. The run error is runtime error... '-2147286788 (800300fc)':
I have altered the save path to
sPath = enviro & "C:\Users\Anthony\Desktop\Email Saved"
Diane Poremsky says
enviro gets the user account part of the path (so you can use the same code on different computers)
Try
sPath = enviro & "\Desktop\Email Saved\"
Maya Headley says
This is an excellent macro and it runs perfectly from VBA when I press F5, but not from Outlook itself. Can you help me troubleshoot? I want to have a button on my ribbon that I could easily press to make changes. I am a beginner, so I can use a lot of help. Thanks!
Diane Poremsky says
Do you get any error messages? Does it work if you run it from Developer ribbon > Macros ?
There isn't any difference with this macro - it should work from either a button or the developer command. If you changed the name of the macro, the button won't work - you might want to remove the button and add it back to make sure the link between the button and macro isn't broken.