Use this code to save messages with the date in the filename, retaining the Outlook file structure.
To save selected messages as PDF files, see Save Outlook email as a PDF
This code sample will save all messages in a specific Outlook folder (and any subfolders of the selected folder) in a folder you select on the hard drive. The messages will be in a subfolder of the selected folder, where the subfolder is named for the Outlook folder you selected.
Note: if you select a subfolder of a top-level folder, for example, a subfolder of the Inbox, folder named Inbox needs to exist in path on the hard drive.
The filename format is yyyymmdd_hhmm_subject.msg, as in:
20100422_0319_Inquiry.msg
The filename is set using this code:
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
Filenames are limited to 256 characters in length, with the subject trimmed if its too long.
Note that it can take some time to run if the folder contains a lot of messages. Allow about 2 seconds per message, or about 15 minutes for 400 messages.
VBA Code
Click in the code area, press Ctrl+A to select all, Ctrl+C to copy then paste into Outlook's VBA editor. Instructions on using the editor are at How to use Outlook's VBA Editor
Option Explicit
Dim StrSavePath As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function
How to use this macro
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 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s 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.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
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
- Save Selected Email Message as .msg File
- Saving All Messages to the Hard Drive Using VBA
karthik says
Dear Diane, Excellent work.
this is saving exactly 1 year's email, what if i want to save all the mails starting from the day1.
Diane Poremsky says
So it quits after saving all messages within a year? how many messages? There is not a timer itn it, so it might be quitting because of the number of messages and not all resources are released. That usually triggers an error though.
Pedro says
Dear Diane, many thanks for this excellent Macro, it is working like a charm and it is actually very helpful. A question: is there any way to automate the process, like running the Macro every time Outlook starts or at a certain time every day ?
Thank you in advance
Diane Poremsky says
Outlook doesn't have a timer, but you can use a reminder to trigger it.
https://www.slipstick.com/developer/code-samples/running-outlook-macros-schedule/
craig says
I noticed emails with RE:[SPAM] do not save, can the code be altered to ignore the word [SPAM] to allow saving
M.Desnoyers says
Hello Diane,
I tried to run this script and there is an "error message" "'76': Path not found." I tried the option "debug" and the line concerned is: "FSO.CreateFolder (StrFolderPath)".
Do you have a solution for that? This script could be so helpfull and great for me!! I hope it could work.
Thank you so much!
Long Le Duy says
aleks says
Thank you for a very useful and smoothly running macro!
Love peace and respect!
Kilimanj99 says
This script is great, exactly what I was looking for. Thank you! I will note I found 2 issues that I'll try to fix. You may already know about these.
Here's where that happens, I made a few mods so I'm not sure the line number, its around 40-45 and at this point strfolderpath = inbox\newfolder what it needs to do is create inbox then create newfolder in 2 seperate actions.
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Neither are a big deal to me, no impact, but thought I'd mention it. If you're looking for improvements it would be really cool if it gave a progress status of some sort. For me it just puts outlook in not responding status until it finishes.
Tammy says
How can I modify the above to get items off a Microsoft exchange server? Code works as long as its not in exchange server.
Diane Poremsky says
It should work with email in any account in Outlook. It won't work with Outlook on the web.
Gorgios says
Hello Diane,
I have the same problem as Tammy. My outook saves automatically emails to a server and after a couple of weeks they're not automatically visible in the folder. In order to see them I have to manually click on "click here to display more Microsoft Exchange elements" in order to see them (in each folder).
So if I run your absolutely excellent macro in a given folder, I have 2 behaviours :
I guess there must be some sort of function/ sub/ procedure in order to simulate this click within the macro itself and hence get all emails.
If I run the macro in a folder where all emails are old, and in MS exchange, I get basically no export at all.
This is weird but very important for me to sort out, otherwise my export is missing a big lot of emails. Many thanks for your help and congratulations for this superb macro.
Gorgios says
I have the same issue as Tammy. This macro is great and works just fine. But it only saves items considered as "available offline", i.e. not on Microsoft Exchange server. Those are not saved (although they are here).
Gorgios says
Hi Diane, thanks this macro is really great. But I do have the exact same issue as Tammy : it saves well all offline mails, but not those which are stored only on the MS exchange server. Is there a fix for that?
Gorgios says
Hello Tammy,
Same problem here. Did you find a solution?
Duncan says
I get the error "Run-time error '76': Path not found. "
Any ideas of how to fix this?
Diane Poremsky says
At what point in the macro does it return this error? It means there is an error in the path - you can add one of these lines right before that line to see what it is using for the path. Which line you use depends on which line it errors on.
msgbox StrSaveFolder
or
msgbox StrFile
Xavier says
hello, i tried to apply this but I keep receiving the error message.
sally says
Hi Diane, so grateful for your work, but when i run it, is said the macros disables even after i changed the settings in trust centre to accept all macros. Would there be any way to fix it? thanks!
Diane Poremsky says
This is after you restarted outlook? Are these new macros - or did you previously use them with a digital signature?
Selly says
Hello Diane,
it is a great work and very useful for me.
I am thankful for your work.
But i would like to choose also sub-folders to save the Emails in this folder to any other folder on the harddrive. Is it possible?
Diane Poremsky says
So you want to save the email in just one folder to the hard drive? This one saves the selected messages to a folder of your choice.
Save Selected Email Message as .msg File (slipstick.com)
Selly says
No. I mean i want to choose and save sub-folders, not Parent folder. Is it possible?
Maros says
Hi. I am working on archivation tool for Outlook. Only problem (or actual) is that I am not able to Save encrypted emails. Your script will skip such mails. It is not possible to extract ReceivedTime nor SenderName from such encrypted Items. I could not find solution for this anywhere on the internet. Do you think it is somehow possible? Thanks.
T. Henein says
Diane. This code is Awesome! Thank you so much!
Dustin Richards says
This is fantastic! What id I want to ignore subfolders and only save emails in a particular folder?
Ron L. says
Hi Diane,
After playing with the script I finally understand how to get it to function as I want it to do. Thank you for posting this.
One question I have is that my company has us in a cached mode and we can only see the past year on our local file. Do you have anything that would actually retrieve from the server? Normally I would use a PST file, however we are restricted on that front as well. Any info you can provide is appreciated.
LynWho says
This is great code. However, I don't need to save the email message, I need to save the excel attachment (that are all uniquely named in each email) to the selected folder. Can you help me update the code for this situation? Thanks.
Diane Poremsky says
I have code to save attachments here:
https://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/
hassan says
Hi Diane,
every time I run the file it gives me an error at :
Set FSO = CreateObject("Scripting.FileSystemObject")
with a run-time error '429'
can you please help me!
Bryan Conner says
It works great. What would I need to include the Sender's info?
Jeff says
Encountering a runtime error around "FSO.CreateFolder (StrFolderPath)" - has anyone fixed this? If so, how? Please post updated code if available.
Diane Poremsky says
Right after StrFolderPath = StrSavePath & "\" & StrFolder & "\" add
debug.print StrFolderPath (or msgbox StrFolderPath ) so you can see if the path is correct and ends with the slash.
Chris says
Hi Diane,
are you able to send me an email? i would like to send you a screenshot, but its not letting me post one. it looks like my path ends with a slash but still getting the above error?
Bryan Conner says
Diane:
Would you be able to provide me any wisdom on adding code to include senders info for easy identification?
Jeff C says
The issue here appears to be related to the variable in place for StrFolderPath:
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrFolder pulls in the folder path selected in Outlook. For instance, if you select folder XYZ within your inbox, StrFolder will equal "Inbox\XYZ". The problem is that "Inbox\XYZ" is appended to whatever folder was selected that provides the location for StrSavePath. As a result, you get StrFolderPath = StrSavePath + "\" + "Inbox\XYZ" + "\". In most cases, people are probably not creating "Inbox\XYZ" within the folder corresponding to StrSavePath.
If you remove ' & StrFolder & "\" ' from the variable above, this code works like a charm.
Hope this makes some sense.
Diane Poremsky says
strfolderpath is built from the browse function -
BrowseForFolder StrSavePath
and the folder path in outlook is created as subfolders within it. The folder is created if it does not exist... however, it only creates 1 level of folders first.
If you select a subfolder, it will not create the parent folder - only the selected folder - and will error. if you select a folder at the same level as the inbox, it will work - and all of the folders under the parent folder will be exported.
Selly says
Hello Diane,
it is a great job and very usefull for me.
I am thankful for your work.
But i would like to choose also sub-folders to save the Emails in this folder to any other folder on the harddrive. Is it possible?
Rajneesh says
Thanks Diane for such a great code. I have one question here if I dont want to use dialogue box for select the hard drive folder so how can i change this code: "Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\")". How can we fix the folder code so that code will run in one go without any dialogue box.
Diane Poremsky says
You need to objFolder to a path:
Set objFolder = "C:\path\to\folder\"
kasper says
Very usefull macro! It has saved me a lot of time on several occations.
However, I am struggeling with a problem this time - It seems like the macro only saves emails that are less than one year old. It might be coursed by some settings related to when the mails are only saved on the servers. Have anyone experiences that as well? Or have a proposal for a solution?
Diane Poremsky says
As written, it works on every message in the folder. I don't know why you'd only be seeing newer messages.
Gorgios says
Same issue here
saurabh says
Its run time error 76 , path not found
saurabh says
Can someone please help me understand how this code would work efficiently for sub folder as well. As of now when I execute it , it gives an error at FSO.CreateFolder (StrFolderPath) as Path not found.
Diane Poremsky says
Add a debug.print StrFolderPath right after that vairable is set. Is it correct? Are you missing slashes between folder paths and file names?
Parker says
If there are 2 emails with the exact same subject and time stamp, there is only retains as it overwrites the other. It is a rare case, but happened to lot of emails in my mailbox. Does any one have suggestions on how to resolve this ?
Diane Poremsky says
you can add an index # to the file (date works well for this) or check for an existing filename and rename future ones. See https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/#changefilename - that adds the date to attachments and there is another macro on that page that adds a number.
Thierry says
Hello,
I have a error with the new Outlook.
Its on the line : Set mItem = SubFolder.Items(j)
Erro in french : "Erreur de compilation : Mécanisme de bibliothèque d'objets non géré"
Do you know what is the problem ?
Thanks,
Thierry
Diane Poremsky says
i believe that error is object not found... so its not finding the subfolder. Do you have the GetFolder sub in it? After
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
add
msgbox subfolder
Is the messagebox empty or does it have a folder name?
Thierry says
I have add "msgbox subfolder"
But i dont have anythink when i run the projet, i have immediately this error
Diane Poremsky says
I added a video to the article so you can see how to use it.
Checklist:
is macro security set to low?
did you restart Outlook?
Add a ' before on error resume next line so errors stop the macro.
Thierry says
Hello,
For resolve my problem i have re-installe office.
And all was OK.
Thanks for all !
Syam says
Very useful tool. However, there are couple fixes are required.
1. Script is not working on the mails in multiple levels of hierarchies. It is not able to create multiple hierarchy dir path. (For me, it failed on managed dirs/vault.) I worked it around the line "FSO.CreateFolder (StrFolderPath)"
2. If there are 2 emails with the exact same subject and time stamp, there is only retains as it overwrites the other. It is a rare case, but happened to lot of emails in my mailbox. I worked it around by adding a suffix if a file exists already with the same name - around the line "StrFile = Left(StrFile, 256)"
chris says
Hi Syam,
Im really new to this can you please let me know what code you used to change the subject line if exactly the same. I really want to use text instead of number.
Example:
Subject line: Hello There
Subject line: Hello There
Will rename them as:
Subject line: Hello There a
Subject line: Hello There b
or really anything you like.
Thanks for your help/
carine says
Hello Syam, At my computer, the macro is also stopping on the line "FSO.CreateFolder (StrFolderPath)" How can I overcome this? How did you manage? I am ok with not having the option to create a folder.
Diane Poremsky says
What path is StrFolderPath trying to use? Add debug,print StrFolderPath (or msgbox StrFolderPath) right after you set the variable and see if its correct. Typical cause is a missing slash between the folder and filename.
Syam says
Nice script. Very useful.
David Starr says
Diane,
I've created a UserForm in VBA for a specific type of Meeting. In that form, there are a number of "custom data fields" to collect information that is not normally part of a standard Outlook Meeting item. Things like the name of the Dealer, the State of said Dealer, a Specific Purpose for the Dealer, etc. When I create a meeting using this form, that information is not present unless I place it all in the message body.
Is there a way to save that information somewhere on the Exchange Server so that it is available at a later date for reporting purposes. We'd like to be able to filter on recipient, Dealer, State, Purpose, etc. so just putting all of this information into the Message Body doesn't seem like it will be a viable option.
Any help you could provide would be greatly appreciated!
Ramon Arxer says
Thanks a lot for this post, very useful.
Ramon Arxer says
Hello again,
I've detected some unusual behaviour: if there is a folder with a special character (for exemple $ or *) the script creates it correctly (without the character), but when the process tries to navegate in the folder to extract the messages, then the process stops.
May be it's solved in a previous post?, I haven't found.
Thanks.
Diane Poremsky says
This is an outlook folder where it stops? I don't recall anyone mentioning it before, so no, i don't think it's solved. It sounds like the special character is messing it up - i would run the folder names though stripillegalchar function too.
Mike Judd says
Morning Diane,
Thanks for this great tool. I have a question on data loss with this. I have a user who has a 23.1Gb PST ( after compacting it and putting it through 2 scanpst.exe), ran it through the macro and comes out 22.0Gb. In the Pst there are 1478 folders in the file structure after the macro there are 1474 folders and ~500 difference in emails. Is this an actually loss in the data or is this just "junk" in the pst and nothing is actually missing?
I also tested this on a 11Gb pst and have a small difference in size.
Diane Poremsky says
Do you know which folders are missing? It could be useless folders like deleted, outbox, etc. Missing messages are either not considered email types (NDRs, meeting requests, etc) or are corrupt. You really can't go by file size - the size in a pst won't necessarily compare to the size on the drive.
you can comment out the on error resume next line and run it on the data file again (using the existing folders previously created) and see if any errors are kicked up - errors on the folders lines indicate a folder is missing, in the save message section, a message can't be saved for one reason or another.
Mike Judd says
Ok great there are a few "error resume next" which one would you be referring to I'm not all that familiar with VBS.
I also did some manual checking on small PSTs and as you said, even though the file size said one thing, when I checked it manually it was the same folder/file number when in the folder structure.
Diane Poremsky says
put an apostrophe in front of each one - when it stops, click Debug.
Tony A. says
Is there VBA code to export everything in Outlook 2013 to a.pst file.?
Diane Poremsky says
I don't think i have any code samples that do it (but will look) - all you need to do is walk each folder and move or copy the items to the new folder. The macro at https://www.slipstick.com/developer/macro-move-aged-mail/ works on the inbox and moves to a new folder but it's easy to point it to a folder in an pst.
Devin says
Diane:
This site and your posts have helped to get me started using VBA in Outlook, which until now I've only utilized VBA in Access & Excel, so thank you.
This and a couple of postings here have got me what I need for the most part to save Outlook messages to a hard drive as MSG files. Now the thing I would like to learn and do next is get the Windows Explorer columns "From", "Subject", "To", "Attachment", etc. to be updated as well as messages get saved to the hard drive. I'd assume that this can be done with VBA code as well. Is this something that you could assist with?
Thank you,
Devin
Paul says
Dear Diane
I just want to say this piece of code is a god-send for me and helped me greatly. Especially as I have 30 projects, each with their own folder/structure in Outlook (basically it's the project name). Now I can export every email in relation to the same folder structure in Outlook onto our server. It works a charm :) Thank you.
However, I have a question, the format your code exports (with date/time proceeding the filename), can it be proceeded by the folder name it is in in Outlook?
Regards
Paul
Patrick van Berkel says
I can imagine. Sorry, I was a bit greedy :). Take your time. I was just worried that it ended up in limbo, but now I know. Thanks for your feedback, I wasn't trying to rush you :). I'm literally in a VBA course now, trying to 'bridge the gap' atleast a little bit. Have a great day. Thank you for looking at my questions when convenient :)
Diane Poremsky says
Well, it is in sort of a limbo - I have a few that have been in this limbo for a lot longer too. :)
Patrick van Berkel says
At the risk of seeming impatient, I left a reply 6 days ago, which still seems to be 'stuck' as it is indicated that it is 'awaiting moderation'. Is there anything wrong with the message I sent?
Diane Poremsky says
No, nothing wrong with the message - I've just been swamped and have been trying to clear out the backlog by answering the really easy questions first. (For every 2 I answer, I swear I get 4 more.) I try to keep messages in moderation until I can answer them, otherwise they get lost and go unanswered. I'll take a look at it next. (This partly why I recommend longer and more complicated questions in forum.slipstick.com as those aren't moderated unless they contain urls and maybe someone else can answer it.)
Patrick van Berkel says
Thanks a lot for that. I understand it a bit better now :). I also figured that the "End If" after the date checking should move all the way down till after the deletion, because otherwise it would still delete all the mails, but only save the ones prior to the date enter.
Hope you don't mind I have some additional questions:
1. When having a pop-up box where user is requested to enter a date, does the format always need to have the 'US'-format? Or can basically any format be used. In China my colleagues use the yyyy/mm/dd format while we in the Netherlands use dd/mm/yyyy.
2. in my folder I had other things stored and not only mails (I also had like meeting invitations), which it didn't touch. Now, that's not really a big deal, but from an understanding point of view, could all 'types' be saved and consequently be deleted?
Again, let me also take the time to thank you again for sharing the code and tweaking it to serve my needs. I see a lot of benefits and potential use. I will share the tool that I will create with this and will obviously mention the source. We've been having a lot of issues with backing up, which even the IT-department wasn't able to come up with a solution, so it's very much appreciated. I just wish that writing code and understanding all the inns and outs would be a skill that I had already acquired in a similar manner as you apparently have. That would make my life and work so much easier :). So, thanks again!!
Diane Poremsky says
1. You can use any format for the date, just rearrange the yyyy mm dd. Those letters tell outlook how to arrange the numbers.
2. This line: Dim mItem As MailItem says to look for an email. Change mailitem to object and it should process everything. If it complains on this line: StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm") because it doesn't have a receivedtime field, add an if - this should work, if not, you'll need to use if/then/else lines.
if mItem.ReceivedTime = "" then mItem.ReceivedTime = mItem.Modified
Patrick van Berkel says
I've managed to fix (this site and googling works wonders) to sort out the 2nd question I had, which leaves 'only' two questions:
1. How do I create a 'date selection' pop-up or something like that where the user can select a date in the calendar, where mails which were prior to the selected date will be saved to the hdd (from each folder and subfolder, and
2. how can I delete each file that I've just saved to the hdd.
Your help is very much appreciated. :)
Diane Poremsky says
Date pickers are difficult to add - but it's easy enough to have people type in the date.
Add this above browseforfolder - it uses a default date of 90 days ago (that can be changed)
Dim age As Date
age = InputBox("Enter the archive date in mm/dd/yyyy format", "Save Date", Date - 90)
BrowseForFolder StrSavePath
Then check the date here -
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
If mItem.ReceivedTime < age Then ' do the save End IfTo delete, use this for the count format: For j = SubFolder.Items.Count To 1 Step -1and this after the save: mItem.DeleteNext j
Patrick van Berkel says
I meant to say; I'm puzzled to why not all mails were processed though in the same folder :).
Diane Poremsky says
they were, but when you delete, it changes the count so every other one ends up deleting - when you have 10 and delete 1, the message that was 3 is now 2.
Patrick van Berkel says
I've tried to understand the code (as I mentioned above, I'm quite new at this), but it's still over my head. I've tried to add a line which I was hoping would delete the email that was just saved by adding a line (the middle line of the three below:
----extract from code----
mItem.SaveAs StrFile, 3
mItem.Delete 'added to try to delete the file we just saved
Next j
-----end of extract----
I've tested it by creating a subfolder and copying like 10 mails in there. It does create an output of having saved some of the files in the folder (but not all) and seems to have deleted those respective files. I'm puzzled to why to all were processed though in the same folder.
Another question that I have is the following:
If I wanted to only save and delete the mails which were received prior to a certain date (in all folders and sub-folders, would you have any suggestion to how I would do that?
Thanks in advance for your help and someday I hope to become as good as you in this as I can see so many benefits.
Kind regards,
Patrick
Patrick van Berkel says
In the test I have just done there are 7 mails in my test subfolder. If I don't run the code without the mItem.Delete line, then it saves all 7 into the folder I've created, however, if I run the code with the line, it only saves 4 mails into the folder I've created which it also deletes from outlook, however 3 remain in the outlook folder.
could someone help me to understand what I'm doing wrong? Thank you!
Diane Poremsky says
you need to count backwards when you delete, otherwise you delete every other one.
Diane Poremsky says
im on my tablet and its hard to do anything serious on it, as soon as im on my desktop, i'll get the necessary code. :-)
Patrick van Berkel says
Amazing!!! Thank you very much for this code. I am a novice in VBA, so unfortunately it's mostly copy-pasting for me and I still have some question for you that you can hopefully help me with. However, I will try to read the code and the comments first in order to try to at least understand it before I ask silly questions :)
Kind regards,
Patrick
Brian says
I'm looking to modify your Outlook VBA Code. I have about 10 reports from 10 different storres that get sent to me every day (outlook has a rule to place these reports into a SubFolder called "Data Extract". Each email attachment report is set up like this: ABCDE (<-- StoreID,)_Report1.xls.
What I need is for the VBA Code (in outlook) to create a new folder on my hard drive (c:\StoreID\) for each Store ID, with the first 5 letters of the attachment (ABCDE) and then all of the attachments with the same first 5 letters of the StoreID, to be saved into their new corresponding folder on my hard drive.
Is this possible? Or would anyone be able to help?
1h249s8 says
This seems possible, but to help you I would need some more info:
- you only want to save the attachment, and not the e-mail?
- every time it saves an attchement, if the folder c:\storeID has not been created yet it has to create a new one?
- All attachments with an existing storeID folder should be saved in this existing folder?
Best regards
Eric
1h249s8 says
Hi, I've upgraded the above code to satisfy my needs, I'm posting it below, main changes are:
1. Macro goes faster because it does not save the same e-mail twice, it checks if the email already exists then skips to the next one.
2. Macro assigns a folderpath to each archive folder and saves it.
3. Macro functions with the selected folder, simply select the folder then click the macro (easy if it is in the quick acces toolbar of outlook.)
///////
CODE
///////
Option Explicit
' This macro saves all e-mails to specific folders on the hard drive. these specific folders are defined by the user,
' once the path of the folder has been entered it is saved in the description of the archive folder, the macro will access this information
' again if the user wants to save new e-mails stored in this archive folder
'
' E-mails that have been saved already are not saved re-saved, the macro verifies the presence of older e-mails (see lines with namelist)
' IN ORDER TO CHANGE PATH OF THE HARD-DRIVE FOLDER, RIGHT-CLICK ON THE ARCHIVE AND SELECT PROPERTIES, THEN REPLACE THE PATH IN THE DESCRIPTION
' DEVELOPPED BY SLIPSTICK TWEAKED BY ERICDS
Sub SaveEmailFOLDER_ProcessAllSubFolders()
Dim st As Currency, et As Currency
st = myTimer
Dim Employees As Collection
Set Employees = New Collection
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim StrSender As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim myObject As Object
Dim mySource As Object
Dim myFile As Object
Dim p As Long
Dim NameList() As String
Dim Count As Long
Dim MailsAdded As Long
Dim InputPath As Variant
Dim fld As Outlook.MAPIFolder
Set fld = Application.ActiveExplorer.CurrentFolder
p = 0
'Set myObject = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
'Set ChosenFolder = iNameSpace.PickFolder
Set ChosenFolder = fld
If ChosenFolder Is Nothing Then
MsgBox "Please select archive folder!"
GoTo ExitSub:
End If
StrSavePath = ChosenFolder.Description
If StrSavePath = "" Then
Enterpath:
InputPath = InputBox("No folder assigned yet, please enter the folderpath. Example : G:\DGP\P_007436_KHAOKORWINDF\MAIL")
ChosenFolder.Description = InputPath
If InputPath = "" Then
GoTo ExitSub:
End If
StrSavePath = ChosenFolder.Description
End If
If Not FileFolderExists(StrSavePath) Then
MsgBox StrSavePath & " - Le fichier n'existe pas ou mauvaise adresse dans vba!"
GoTo Enterpath:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) ' All subfolders of outlook and the main folder are checked for e-mails
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
'MsgBox i & " " & StrFolder
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath '& StrFolder & "\" ' I do not use strfolder, all subfolders in outlook are saved in the same folder on the hard drive
'MsgBox StrFolderPath
'MsgBox StrFolder
'MsgBox i & " " & StrFolder
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
Set mySource = FSO.GetFolder(StrSaveFolder)
On Error Resume Next
On Error Resume Next
If NameList(0) = "" Then ' the list is only made once for each subfolder in outlook
'MsgBox "ok"
ReDim NameList(0 To mySource.Files.Count)
For Each myFile In mySource.Files
'MsgBox Employees.Item(1)
NameList(Count) = myFile.Name
Count = Count + 1
Next
End If
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = StripIllegalChar(Left(mItem.ReceivedTime, 10))
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSender = Left(mItem.SenderName, 15)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "-" & StrSender & "_" & StrName & ".msg"
'MsgBox StrFile
StrFile = Left(StrFile, 256)
'MsgBox mySource.Name
For p = 0 To Count
'If Employees.Item(p) = StrReceived & "-" & StrSender & "_" & StrName & ".msg" Then
'MsgBox "trouvé"
'Employees.Remove (p)
'GoTo SaveTime
'End If
If NameList(p) = StrReceived & "-" & StrSender & "_" & StrName & ".msg" Then
GoTo SaveTime
End If
Next p
MailsAdded = MailsAdded + 1
mItem.SaveAs StrFile, 3
SaveTime:
Next j
On Error GoTo 0
Next i
et = myTimer
'MsgBox Format(myElapsedTime(et - st), "0.000000") & " seconds"
If MailsAdded = 0 Then
MsgBox "Folder was already up to date!"
Else
MsgBox MailsAdded & "/" & Count & " mails added to folder in " & Format(myElapsedTime(et - st), "0.000") & " seconds " & vbNewLine & " Folder is up to date!"
End If
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add fld.FolderPath
EntryID.Add fld.EntryID
StoreID.Add fld.StoreID
For Each SubFolder In fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
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
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function
Public Function FileFolderExists(strFullPath As String) As Boolean
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
Timothy Dollimore says
Um, probably shouldn't use // as the inline comment marker for VBA, doh! :-)
Timothy Dollimore says
One thing I like to be able to do is timestamp the messages so they physically show up in the file system with their receive date.
https://www.freevbcode.com/ShowCode.asp?ID=1335
Create an extra module with this in it
Option Explicit
'https://www.freevbcode.com/ShowCode.asp?ID=1335
'Change a File's Last Modified Date Stamp
'Category:Files and Directories
'Type:Snippets
'Difficulty:Intermediate
'Author: Intelligent Solutions Inc.
Private Type FILETIME
dwLowDate As Long
dwHighDate As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMillisecs As Integer
End Type
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_WRITE = &H40000000
Private Declare Function CreateFile Lib "kernel32" Alias _
"CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) _
As Long
Private Declare Function LocalFileTimeToFileTime Lib _
"kernel32" (lpLocalFileTime As FILETIME, _
lpFileTime As FILETIME) As Long
Private Declare Function SetFileTime Lib "kernel32" _
(ByVal hFile As Long, ByVal MullP As Long, _
ByVal NullP2 As Long, lpLastWriteTime _
As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib _
"kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime _
As FILETIME) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Public Function SetFileDateTime(ByVal FileName As String, _
ByVal TheDate As String) As Boolean
'************************************************
'PURPOSE: Set File Date (and optionally time)
' for a given file)
'PARAMETERS: TheDate -- Date to Set File's Modified Date/Time
' FileName -- The File Name
'Returns: True if successful, false otherwise
'************************************************
If Dir(FileName) = "" Then Exit Function
If Not IsDate(TheDate) Then Exit Function
Dim lFileHnd As Long
Dim lRet As Long
Dim typFileTime As FILETIME
Dim typLocalTime As FILETIME
Dim typSystemTime As SYSTEMTIME
With typSystemTime
.wYear = Year(TheDate)
.wMonth = Month(TheDate)
.wDay = Day(TheDate)
.wDayOfWeek = Weekday(TheDate) - 1
.wHour = Hour(TheDate)
.wMinute = Minute(TheDate)
.wSecond = Second(TheDate)
End With
lRet = SystemTimeToFileTime(typSystemTime, typLocalTime)
lRet = LocalFileTimeToFileTime(typLocalTime, typFileTime)
lFileHnd = CreateFile(FileName, GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, _
OPEN_EXISTING, 0, 0)
lRet = SetFileTime(lFileHnd, ByVal 0&, ByVal 0&, _
typFileTime)
CloseHandle lFileHnd
SetFileDateTime = lRet > 0
End Function
Then change the SaveAllEmails_ProcessAllSubFolders routine
like so (I've changed the timestamp in the message so its at the end; using human readable format; and wrapped in parentheses)
Dim StrReceived As String
Dim StrSent As String \\ additional variable to hold good timestamp
Dim StrFolder As String
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "hhmmss DD MMM YYYY")
StrSent = Format(mItem.ReceivedTime, "hh:mm:ss DD/MM/YYYY") // passed to SetFileDateTime
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrName & " (" & StrReceived & ").msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
SetFileDateTime StrFile, StrSent // Et voila! now the messages have the time as their last modified date (in addition to the title )
Next j
santinimatias says
Diane,
For the longest time I've been looking for a code like this one, Thank you so much!.
In my office we typically save emails in a "Project" correspondence folder (with their correspondent sub-folders). We also have a filename system that shows as follows:
E 14-1007 1
E 14-1007 2
E 14-1007 3
E 14-1008 1
E 14-1008 2
E 14-1009 1
E 14-1010 1
As you see, we have an "E " + mail date received + counter.
All this is done by "hand", by drag and dropping from Outlook to the target folder....taking hours and hours....
I was already able to modify the filename standard to look as follows:
E 14-1007 1
E 14-1007 2
E 14-1008 3
E 14-1008 4
(counter keeps going, no matter the date)
The first thing I'm trying to do is to have the counter to be related to the date, so for each new date in the filename then the counter starts over.
The second goal is to have the code to check in the correspondence folder if the filename already exists, so it can save the email with the next logical counter number.
for example, if the files below already exists in the target folder:
E 14-1007 1
E 14-1007 2
E 14-1007 3
and I need to save other emails with the same date, it would save them as follows:
E 14-1007 4
E 14-1007 5
E 14-1007 6
and so on.......
I am not a programmer, so any help would be greatly welcome.
Here is the code I have: (I'm aware there are parts of the code that will NOT be needed anymore, since the filename is so specific).
Macro code
Diane Poremsky says
As long as you don't need to keep track of dates, it shouldn't be too tough to do. ie, dates are done in order and when you move to the next day, you won't have any more messages for the day before.
Set a variable for the received date of the first message and compare it to the mail_recieved_time variable. When DD is up 1, restart the counter. something along these lines:
start_date = format(outlook_mail_item.ReceivedTime, "DD")
received_date = Format(outlook_mail_item.ReceivedTime, "DD")
if received_date = start_date then
' keep incrementing
else
counter = 1
end if
if the macro is erroring if the filename exists, this is easy - use an error handler to change the filename by one. If it doesn't error, you'll need to check for the filename and raise the count if found.
mhegeral@live.com says
thank you very much. the first worked for me. i just needed to creat the target folder.
Paddy says
If you take a look at the script I mentioned above, I shortened down the "action" part to:
If strFileType = ".msg" Then
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
openMsg.Display
openMsg.Copy (DestiNation.FolderPath)
openMsg.Close olDiscard
Set openMsg = Nothing
End If
The problem is the .copy line. DestiNation is a MAPIFolder and generated from a simple string using the following function. It works in other contexts, but not this time.
Public Function GetFolder(ByVal FolderPath As String) As Outlook.folder
Dim TestFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolder_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
If Right(FolderPath, 1) = "\" Then
FolderPath = Left(FolderPath, Len(FolderPath) - 1)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
If Not TestFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.item(FoldersArray(i))
If TestFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TestFolder
Set GetFolder = TestFolder
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
In the end however, it returns error 440, "object does not support the method". I must have declared something wrong, and this is exactly where my VBA knowledge comes to a sudden end... Any suggestions?
Diane Poremsky says
I think it's with this:
openMsg.Copy (DestiNation.FolderPath)
Are you putting them back in the same path in outlook? I'm getting object variable on the destination folder.
However, a bigger problem is that the messages are opening as drafts, not messages.
Diane Poremsky says
this might be one option: http://www.outlookcode.com/threads.aspx?forumid=4&messageid=26038
ETA I'm getting the same result with redemption - a draft, not the message as a received message. some were in the outbox, which will generate an error as they can't be resent.
Paddy says
Dear Diane,
thank you for the great script that really shortened my own development time, which is rather down to trial and error.
What I'm looking for now is a script to reverse what the one above just did, which means re-integrate msg files in a folder and subfolders in my Outlook archive.
Select a folder with msg files and other folders on the HD, create folders in the Outlook archive, according to the ones found in the "master" folder, copy all msg files and so on,
I used the script found here (https://www.slipstick.com/developer/open-outlook-messages-stored-filesystem/), which is already a great basis. Howver, the final step from opening the msg file and storing it somewhere in Outlook won't work. Any ideas?
Cheers
Paddy
Diane Poremsky says
How are you trying to get them back in? Haven't verified it will work, but I'd use (or try :)) move:
mItem.move saveFolder
display the message, move it to a folder and then save it.
Galen says
I tried the fix listed above and encountered a couple of problems with this approach as is. I was, however, able to see what needed to be changed and it now works for what I want... mostly...
StrFile = StrSaveFolder & StrReceived & " " & mItem.SenderName & " " & StrName & ".msg"
This puts the email sender's name after the time/date stamp and separates it from the stamp and the subject by a couple of spaces.
The only problem I can see is that this will probably pull in my email name as the sender for all "Sent" messages rather than providing me with the recipients name. I think I can figure that out and use some sort of logic statement to pull in the correct field.
Thanks, again, for getting me on the correct path. (pardon the pun.)
Diane Poremsky says
Sent messages will be your name - see https://www.slipstick.com/developer/recipient-email-address-sent-items/ for the bits of code needs to get the recipient information. Use .Name instead of .address - you'll need to clean it the same way the subject is stripped of illegal characters.
Galen says
Thanks a million for the assistance. I will give it a try in the morning.
Galen says
Dianne,
I have your original code at the top of the page working for my needs except I would like to add one additional item and I am not sure how to do it...
After the Date entry, and before the Subject in the new file name, I would also like to include the sender's name separated from the date by a space, likewise before the subject. Can you advise what this extra code should look like?
Diane Poremsky says
This is where the file name is put together:
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
You'd add mItem.sender to it.
StrFile = StrSaveFolder & mItem.sender & " " & StrReceived & "_" & StrName & ".msg"
Bavaria says
ok, to show you, in my case it is even more Information what I liked to have (but I did not like that for resulting identical names only one file was created, therefore I used the "j" as number to see "duplicated emails"):
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrSenderEmail = mItem.SenderEmailAddress
StrRecipiEmail = mItem.To
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrSenderEmail & "__" & StrRecipiEmail & "__" & StrName & ".msg"
StrFile = Left(StrFile, 256)
If Dir(StrFile, vbNormal) "" Then
StrFileNeu = Left(StrFile, InStrRev(StrFile, ".") - 1) & "-" & j & ".msg"
mItem.SaveAs StrFileNeu, 3
Else
mItem.SaveAs StrFile, 3
End If
Next j
To explain why I need your code: I worked for more than 15 years very happy with Outlook 2000 and kept my PST-Files always under 2GB (handled them like raw eggs, used backups, copies and so on) and "maintained" them well with SCANPST.EXE. Now I changed to OUTLOOK 2013, made new PST-Files with new OL2003andup-Format and copied the content from the old OL2000-PST-Files into them. The thing/problem is that always if I use the NEW SCANPST.EXE it reports "minor inconsistencies". Also if I use it on a brandnew PST-File.
I use your code because on/for the side of the file system with the created .msg files I have more tools to compare and analyze them than when I am in OUTLOOK. And I have msg-copies/backups of my old emails also. Few days before I had written you an email because I think there is a problem with scanpst.exe, and followed also your other comments on this topic on other places in the web. ..I´m in the process to analyze why this happens.
Bavaria says
Dear Diane, thank you very much for your work, your time and not only for this code and your time for comments.
(In my very special case: the received date and time was not enough - maybe the time in seconds could work - but I choosed just the "j" in the "For" loop to get a simple unique number added to the names".)
Diane Poremsky says
the advantage of using a number rather than the date is size - the full date and time adds 14 characters, more if you use separators. You could use the current time serial for the code, it's still 6 (or 8?) digits. A for loop that increments would result in shorter file names.
Bavaria says
Just for your Information: one thing to mention:
"Problem": If there are more emails (with "nearly" identical conditions but definetely no dublicates, which result in the same identical StrFile) in a email older, then only one email is created as file!
But thank you very much for the code!
I have modified your code and solved this "problem" with this code:
CUT
StrFile = Left(StrFile, 256)
If Dir(StrFile, vbNormal) "" Then
StrFileNeu = Left(StrFile, InStrRev(StrFile, ".") - 1) & "-" & j & ".msg"
mItem.SaveAs StrFileNeu, 3
Else
mItem.SaveAs StrFile, 3
End If
Next j
CUT
Diane Poremsky says
Yeah, if there are messages that will create identical file names, you need to do something to make them unique. One of my scripts here adds the received date and time to avoid problems.
JAIME says
Hi ! i have a problem with this code, i already have the directory to save the emails, and i know wich folder in outlook i want to select.
where i can replace this information ?
i think i have to change this:
Set ChosenFolder = iNameSpace.PickFolder
for this:
Set ChosenFolder = iNameSpace.folders("personal folders").folders("inbox")
this solve the folders problem.
and change this:
BrowseForFolder StrSavePath
for:
strsavepath = "C:\test\"
for solve the directory problem.
Now im having problem with this new code, because in my computer (outlook 2013) its working, but in my friend computer (outlook 2007) isnt working. how i can fix this ?
im trying to save the last message (most recent) to the hard drive in .msg format. THANKS ! C:
Kris says
Final comment / request2 for the day:
1. If you run it on the same folder, it will not overwrite (or ignore for speed) the existing msg, it will create a new one? Anyone have a solution to get around that?
2. Second request, for dates to be at the start of the message, do i just invert this from
mail_file_fullname = disk_folder_path & mail_filename & "_" & mail_received_time & "_" & mail_counter
to
mail_file_fullname = mail_received_time & disk_folder_path & mail_filename & "_" & "_" & mail_counter
?
Thanks!
Kris
Diane Poremsky says
1. You'd need to check for duplicate filenames before you create the file. Or, add a value or category to the message and skip items in the category or with a certain value in a custom field.
2. Yes, you just need to change the order of the fields when the name is constructed.
Kris says
1. Could someone please post's eric complete solution for speeding it up please?
2. If you do not want to have the macro save atatchments out, then in Philips last post delete this section:
'Save attachements where the format does not do it automatically
If mail_file_type "msg" Then
'Go through all attachments
For mail_attachment_counter = 1 To outlook_mail_item.Attachments.Count
'Get the attachment file name from Outlook
mail_attachment_filename = outlook_mail_item.Attachments(mail_attachment_counter).filename
'Separate file extension and file name
mail_attachment_extension = Right(mail_attachment_filename, Len(mail_attachment_filename) - InStrRev(mail_attachment_filename, "."))
mail_attachment_filename = Left(mail_attachment_filename, InStrRev(mail_attachment_filename, ".") - 1)
'Shorten overlong filenames
mail_attachment_filename = Left(mail_attachment_filename, 50)
'Cleanup the file name
mail_attachment_filename = Remove_Illegal_Characters(mail_attachment_filename)
'Outlook permits to add the same file name twice to a message.
'Put the filename back together and add a counter to be unique
mail_attachment_filename = mail_attachment_filename & "_" & mail_attachment_counter & "." & mail_attachment_extension
'Use the mail file name (without extension) plus the attachment name separated by -- as file name
'(otherwise it would be unclear to which message the attachment belongs)
outlook_mail_item.Attachments(mail_attachment_counter).SaveAsFile mail_file_fullname & "--" & mail_attachment_filename
Next
End If
===================================================================
eric says
Hi Kris
Here's my entire code to go faster and to not have duplicates:
I go faster by checking if the file already exists (for each folder and subfolder), if the e-mail is already saved then it will not be overwritten.
Macro code
Kris says
There's a wee typo here in Phillips post
If mail_file_type "msg" Then
should this be
If mail_file_type = "msg" Then
eric says
OK, I defined mysource as a folder and myfiles as a file, everything is working, the code is running way faster now... sorry for the multiple posts, you can remove them if you want and just post the final solution, if you agree it's an good upgrade to your code of course.
Anyway, many thanks for the code, this is just what I needed!
Diane Poremsky says
Thanks for the update. I'll leave the other posts, it may help someone who is having problems getting their code to work.
eric says
Ok, I understand why it's not working, didn't see the option explicit, however, i'm kind of a bad in object defining and I don't know how to dimension "mysource" and "myfiles".
Do you know how to make this work.
eric says
Compile error:
variable not defined
with myobject highlighted.
eric says
Hi Diane,
If I use your code on a lot of large e-mails it might take some time , that's why i would like to check if the filename does not already exist in the selected folder in order not to resave e-mail unnecessarily and also to be able to save e-mails to a server used by multiple people saving in the same folder,
The code i had in mind would be something like this
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(StrSaveFolder)
On Error Resume Next
For Each myfile In mySource.Files
If myfile.Name = StrFile Then
MsgBox "It's working!"
GoTo SaveTime
End If
Next
mItem.SaveAs StrFile, 3
SaveTime:
Unfortunately this only works in vba-excell, I don't know how to make it work in outlook.
Any ideas?
Tanks
Diane Poremsky says
It uses FSO, so if it works in excel, it will work in Outlook. What error message do you get?
Thom says
Shouldn't
disk_folder_path = disk_root_path & outlook_folder_path & "\"
be
disk_folder_path = disk_root_path & "\" & outlook_folder_path & "\"
Diane Poremsky says
it depends if the disk_root_path has the ending \.
Philipp Post says
The issue is just with the .ReceivedTime which we cannot get from a read receipt (which is of MessageClass "Report.IPM.Note.IPNRN")
Have fixed that and added saving the message in other formats as well and then saving the attachements separately. PDF via Word works, but is slow on lots of messages and does not save embedded pictures.
Macro sample
Diane Poremsky says
Do you need to save read receipts? If you only want messages, use an if statement.
if outlook_mail_item.messageclass = "ipm.note" then
' do the save
end if
on slow pdf's, see Javier's comment - if you can keep word open, it should be faster.
Thom says
The error occurs every time it encounters a read receipt.
Diane Poremsky says
Ah. On Error Resume Next after the DIM and Set statements should fix it, or add an If statement -
If mItem.messageclass = ipm.note then
' do the save
else
end if
next j
Philipp Post says
You could try the following to trace the issue: out comment (put a ' in front of) "On Error GoTo error_handler", then run the procedure till the error ocurrs and press debug. Look at what code line the error comes up and post this back, pls. You can hover with them mouse over the variable names to see their values (is some of them wrong or empty?) Further analyze the mail item which caused the error as Diane said.
Andrzej says
I finally found the error, using the Debug.Print wrongly kept me from finding it faster... it was a mail item that consisted of a Word Document - seems like DOC was not attached, but the email itself (probably sent from within Word). That's why the script failed in grabbing the received time, subject etc. and crashed. All good now. Thanks again!
Andrzej says
Thanks to you, Philipp and Diane, for all the hints and changes!
One next issue came up, though - while the script worked well on the first ~6000 messages I ran it on, I tried using it on the next batch of messages and got the error message: "Object doesn't support this property or method (438)" - any idea where this comes from? I got it with both my revised v1 of Philipp's script and the v2 he posted above. I tried to debug.print, but the error comes before/after various types of emails, and removing these does not seem to solve the problem. Thanks for any advice y'all might have!
Diane Poremsky says
Is the message signed? What attachments are on the message? Do they have special characters in the the filename?
Philipp Post says
I do think so too, Diane. - Thanks to all for the feedback. In fact the issue was not within the Replace but a leftover from the old code which cause paths with double \\. Fixed that and changed replacement of illegal chars to REGEX. Brgds Philipp
Macro sample
Tony Rockdaschel says
It ended up that I had one more "Replace" than I had invalid characters to be replaced. I removed one Replace and all is well.
Diane Poremsky says
I didn't write that code but every time I look at it I think I should replace it with an easier-to-read replace character function. :)
Andrzej says
Hey - I had the same problem, and I think the backslash was simply omitted in the list of characters to be replaced... I changed the section to the following and now it works.
'Clean out invalid chars
outlook_folder_path = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(outlook_folder_path, "", ""), _
":", ""), _
"""", ""), _
"\", ""), _
"/", ""), _
"|", ""), _
"?", ""), _
"*", "")
Now the code runs quite well - thanks so much to everyone that contributed! Only one problem remains - after a couple of hundred emails saved, I get the -2147286788 error, which apparently stands for "(800300FC) The name %1 is not valid." Any idea why that happens and how it can be fixed?
Diane Poremsky says
Have you identified the message that is tripping it up? I'm guessing there is a character, possibly a non-printable character, that is tripping it up. The code at https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/ has a longer list of invalid characters (some are valid in windows but cause problems in sharepoint) but before you try stripping more characters, add a debug.print to see what it getting processed.
This should capture the message subjects before the error is triggered. Open the VB Editor and press Ctrl+G to see the list.
Set mItem = SubFolder.Items(j)
debug.print mItem '(or mitem.subject)
Andrzej says
Can't thank you enough for your swift help, Diane... that Debug.Print hint helped me solve the problem... a double-space in a file name was the issue, I added a few more lines to the character replacement in the filenames (to include all the characters from the PDF script, and potential double- and triple spaces in the subject line), and now the script works like a charm, even on a monster folder with close to 6,000 emails. Thanks to you and Philipp's efforts!
See here for the modified section that should help with potential character issues, maybe you can change that in the downloadable .txt file as well?
filename = Replace(filename, "", replacing_char)
filename = Replace(filename, ":", replacing_char)
filename = Replace(filename, """", replacing_char)
filename = Replace(filename, " ", replacing_char)
filename = Replace(filename, " ", replacing_char)
filename = Replace(filename, "/", replacing_char)
filename = Replace(filename, "\", replacing_char)
filename = Replace(filename, "|", replacing_char)
filename = Replace(filename, "?", replacing_char)
filename = Replace(filename, "*", replacing_char)
filename = Replace(filename, "", replacing_char)
filename = Replace(filename, "&", replacing_char)
filename = Replace(filename, "%", replacing_char)
filename = Replace(filename, "{", replacing_char)
filename = Replace(filename, "[", replacing_char)
filename = Replace(filename, "]", replacing_char)
filename = Replace(filename, "}", replacing_char)
filename = Replace(filename, "!", replacing_char)
Tony Rockdaschel says
I'd love to get this code working but I get a syntax error for this part using Philip's code above. Can you help me figure out why?
'Clean out invalid chars
outlook_folder_path = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(outlook_folder_path, "", ""), _
":", ""), _
"""", ""), _
"/", ""), _
"|", ""), _
"?", ""), _
"*", "")
Diane Poremsky says
try adding a second ) after the very last one.
Philipp Post says
Have cleaned up the variable names, fixed the issue with folders which could not be created, fixed stripping just the filename and not the whole path, char replacement rewritten. Thanks a lot to Diane for posting the initial idea!
text file containing macro
Diane Poremsky says
Thanks for sharing! A text file containing the code is available here.
Phuc Dinh Cong says
Thank the Author. Here is my debug, it works even not perfect coding
text file containing macro
M@rtin says
thanks for your quick replies andn for the changes in the code!
There is one more question/wish from my side:
How could the code be changed to act only on the current selection?
Kind regards
Diane Poremsky says
See save-selected-message-file for a macro that saves the selected message (or messages) as .msg files. It doesn't recreate the folder path though.
M@rtin says
p.s. for me it seems to work, if you replace the line
StrReceived = ArrangedDate(mItem.ReceivedTime)
by
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm").
The date format "YYYYMMDD-hhmm" could then be defined according to the vba conventions.
Another thing that came to my mind:
it would be nice to remove forbidden characters (forbidden regarding filenames ion the different operating systems!) from the subject.
I assume there exists ready-to-run functions which take a string and remove all frobidden characters or replace them by something else like "_").
Kind regards
Martin
Diane Poremsky says
The StripIllegalChar function should remove all invalid characters - you could change it to replace them:
StripIllegalChar = RegX.Replace(StrInput, "_")
There is another function here that uses vba, not regex, to cleanup filenames.
Diane Poremsky says
BTW, thanks for bringing this sample to my attention. It had more goofiness than just the received date. It was one of the code samples that was left on the site when OutlookCode split off and I think I know why it was left behind, it was a piece of... :)
M@rtin says
Hi Diane,
thank you very much for this example!
This is incredibly useful and nearly exactly what I was looking for!
Unfortunately, however, for me the date string produces strange results. I assume that this is, because I'm working on Windows 7 with Office 2007 and German language/date settings.
I'm not an expert at all, so maybe this is a stupid question, but the ArrangedDate function in your code looks quite complicated to me.
Wouldn't it be easier (and maybe more foolproof) to use something like Format(objmail.ReceivedTime, "YYYY-MM-DD hh:mm")?
Kind regards
Martin
Diane Poremsky says
It is likely because you are using German or at least using a different date format. You can change it to use whatever format you want - I'm just providing examples of what is possible. :)
Nolberto Gaviria says
Thank you very much for sharing your knowledge. God bless you.
HS says
Yes.... That is definitely the problem... Any solution?
rich says
thanks diane - how can i edit your code to save as .pdf instead of .msg? Thanks!
Diane Poremsky says
Because PDF is not a native format that Outlook saves as, you need to use the word object model to save as PDF. See save email as pdf for a code sample.
Adrian Rutter says
Thanks Diane, really useful code.
The issue experienced above appears to lie in creation of the folders if the user has not created the specified root folder for emails prior to executing. In my case, the first folder it tried to create was not Messages, but Messages\Inbox and if the parent folder does not exist, it cannot create the Inbox Sub-Folder...
Simple fix, only direct the output to an existing folder.
Code Fix, check and create the lower mailbox folder structure prior to the strFolderPathloop.
It also only appears to run if you select the root folder of your mailbox, I select a subfolder, it does not build up the tree from the root.
If I tried to extract my Friends folder (Mailbox\Inbox\Friends) it tries to create Messages\Inbox\Friends first and not Inbox to allow Inbox\Friends to be created.
Travis says
Diane,
I am having the same issue as Tom. I removed the trailing slash and also changed the path to my documents folder. the code still stops at the same place :
FSO.CreatFolder (StrFolderPath)
Any ideas?
Thanks for all your help...
Diane Poremsky says
press F8 to step through it - which line does it quit at?
Which version of Outlook? I'll double check and make sure it's not missing a reference - as long as the main folder exists ( StrSavePath = "c:\Messages\") it should run without changing anything in Tools, references.
Diane Poremsky says
What version of Outlook? Press F8 (over and over) to step through the macro. Which line does it stop on?
Izbi says
Diane
I have similar issues.
The macro works perfectly for the INBOX and folders at the same level as the inbox.
However if I choose a folder beneath this level, I get the error message "Run time error '76', Path not found.
Diane Poremsky says
That error means the macro can't find the path. I don't know why - it's working here. (and i stupidly tested it on a folder/subfolders each with like 2000 messages.)
Izbi says
OK thank you again,
Tom says
Hey Diane, I tried your VBA code in Outlook 2010 and am getting the Run-time error '76': Path not found.
I changed the code so that StrSavePath = "c:\Messages\" is a folder on my hard drive. The error stops at: "FSO.CreateFolder (StrFolderPath)"
Any idea of why this would be happening?
Thanks for your help!
Diane Poremsky says
It sounds like the path does not exist - triple check for typos. Also, try a folder in my documents - there are sometimes problems writing to the c drive (permissions).
One way to test the code is to remove the trailing slash -
StrSavePath = "c:\Messages"
The code should create the folder (and append the outlook folder name to it) - if that works, the folder path wasn't right.