RSSUse 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
![Diane Poremsky [Outlook MVP]](http://cdn.slipstick.com/images/2013/mvp-icon.png){kind=icon}
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!
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.
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...
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.
What version of Outlook? Press F8 (over and over) to step through the macro. Which line does it stop on?
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.
thanks diane - how can i edit your code to save as .pdf instead of .msg? Thanks!
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.
Yes.... That is definitely the problem... Any solution?
Thank you very much for sharing your knowledge. God bless you.
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
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. :)
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
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.
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... :)
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
See for a macro that saves the selected message (or messages) as .msg files. It doesn't recreate the folder path though.
Thank the Author. Here is my debug, it works even not perfect coding
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
Dim TotalMail As Single
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
Dim n2 As Single, MidStr2 As String, DoneFolder As Boolean, midStr3 As String, midstr4 As String, midSavepath2 As String
midSavepath2 = StrSavePath
DoneFolder = False
midstr4 = StrFolder
Do While DoneFolder = False
n2 = InStr(1, midstr4, "\")
If n2 > 0 Then MidStr2 = Mid(midstr4, 1, n2 - 1) Else MidStr2 = midstr4
midStr3 = midSavepath2 & "\" & MidStr2 & "\"
If Not FSO.FolderExists(midStr3) Then FSO.CreateFolder (midStr3)
If Not FSO.FolderExists(StrFolderPath) Then DoneFolder = False Else DoneFolder = True
midstr4 = Mid(midstr4, n2 + 1, 256)
midSavepath2 = Mid(midStr3, 1, Len(midStr3) - 1)
Loop
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
TotalMail = TotalMail + 1
Next j
On Error GoTo 0
Next i
MsgBox TotalMail & " DONE"
ExitSub:
End Sub
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!
Option Explicit
'--------------------------------------------------------------------------------------------------
'Description: Saves all Messages out of the selected Outlook folder to the Hard Drive
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change to work inside Excel, bug fixes, change naming convention
'Comments: Does NOT need reference to Microsoft Outlook 12.0 Object Library
' Use of late binding. Needs to declare all Outlook specific types as Variant
' and use CreateObject("Outlook.Application") as in case of missing Outlook Libraries
' the whole vba app stops working
'Readings: Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
' Late Binding: http://msdn.microsoft.com/en-us/library/office/ff865816.aspx
' Save As Types: http://msdn.microsoft.com/en-us/library/office/bb175283(v=office.12).aspx
'--------------------------------------------------------------------------------------------------
Sub Save_Outlook_Mails_To_Disk()
Dim outlook_app As Object 'Outlook.Application
Dim outlook_mail_item As Variant 'MailItem
Dim folder_counter As Long
Dim folder_mail_counter As Long
Dim outlook_folders As New Collection
Dim outlook_entry_ids As New Collection
Dim outlook_store_ids As New Collection
Dim outlook_start_folder As Object
Dim outlook_folder As Variant 'MAPIFolder
Dim outlook_folder_path As String
Dim outlook_folder_path_strip_length As Integer
Dim disk_root_path As String
Dim disk_folder_path As String
Dim disk_folder_name As String
Dim mail_subject As String
Dim mail_filename As String
Dim mail_file_fullname As String
Dim mail_received_time As String
Dim mail_counter As Long
'For Folder open dialogue
Dim shell_app As Object
Dim folder_obj As Object
On Error GoTo error_handler
Set outlook_app = CreateObject("Outlook.Application")
mail_counter = 0
'Select the Outlook Folder to save to disk
'Opens a folder picker popup window
Set outlook_start_folder = outlook_app.GetNamespace("MAPI").PickFolder
'User canceled folder selection
If outlook_start_folder Is Nothing Then
Exit Sub
End If
'Obtain the save to disk root folder
'Opens a folder picker popup window
Set shell_app = CreateObject("Shell.Application")
'With start folder set
'Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0, "U:\RHH0T322 - GTM\")
'Without start folder set
Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0)
'User canceled folder selection
If folder_obj Is Nothing Then
Exit Sub
End If
disk_root_path = folder_obj.self.Path
'Fill the outlook folder structures
Call Get_Outlook_Folders(outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_start_folder)
'Go through all folders
For folder_counter = 1 To outlook_folders.Count
outlook_folder_path = outlook_folders(folder_counter)
'Clean out invalid chars
outlook_folder_path = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
outlook_folder_path, "", ""), _
":", ""), _
"""", ""), _
"/", ""), _
"|", ""), _
"?", ""), _
"*", "")
If folder_counter = 1 Then
'Put the selected folder name to the disk
'outlook_folder_path_strip_length = Len(outlook_folder_path) - Len(outlook_start_folder) + 1
'Do not put the selected Outlook folder name to disk
outlook_folder_path_strip_length = Len(outlook_folder_path) + 1
End If
outlook_folder_path = Mid(outlook_folder_path, outlook_folder_path_strip_length)
disk_folder_path = disk_root_path & "\" & outlook_folder_path & "\"
disk_folder_name = Left(disk_folder_path, Len(disk_folder_path) - 1) & "\"
'Create directory if missing
'Cannot create a directory tree in one go (folder + subfolder)
'Just one hierarchy item at a time
If Dir(disk_folder_path, vbDirectory) = "" Then
MkDir (disk_folder_path)
End If
Set outlook_folder = outlook_app.Session.GetFolderFromID(outlook_entry_ids(folder_counter), outlook_store_ids(folder_counter))
'Go through all mail items in the present folder
For folder_mail_counter = 1 To outlook_folder.Items.Count
Set outlook_mail_item = outlook_folder.Items(folder_mail_counter)
mail_counter = mail_counter + 1
mail_received_time = Format(outlook_mail_item.ReceivedTime, "YYYY-MM-DD_hhmm")
'shorten overlong mail subjects
mail_subject = Left(outlook_mail_item.Subject, 100)
If mail_subject = "" Then mail_subject = "No Subject"
mail_filename = Clean_Mail_Filename(mail_subject)
mail_file_fullname = disk_folder_name & mail_filename & "_" & mail_received_time & "_" & mail_counter & ".msg"
'OlSaveAsType Constants (must also change the file extension)
'olTXT = 0 / olRTF = 1 / olTemplate = 2 / olMSG = 3 / olDoc = 4
'0 and 3 work with any message, the other formats do not
outlook_mail_item.SaveAs mail_file_fullname, 3
Next
Next
MsgBox mail_counter & " mails saved to disk.", vbInformation, "Save Outlook Messages To Disk"
Exit Sub
error_handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk"
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Fills the passed variables with Outlook Folder structures
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change naming conventions
'Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
'Comments: Calls itself recursively to get the full folder tree
' Needed for Save_Outlook_Mails_To_Disk
'--------------------------------------------------------------------------------------------------
Sub Get_Outlook_Folders(outlook_folders As Collection, outlook_entry_ids As Collection, outlook_store_ids As Collection, outlook_current_folder As Variant)
Dim outlook_subfolder As Variant 'MAPIFolder
On Error GoTo error_handler
outlook_folders.Add outlook_current_folder.FolderPath
outlook_entry_ids.Add outlook_current_folder.EntryID
outlook_store_ids.Add outlook_current_folder.StoreID
For Each outlook_subfolder In outlook_current_folder.Folders
Get_Outlook_Folders outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_subfolder
Next
Set outlook_subfolder = Nothing
Exit Sub
error_handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Get_Outlook_Folders"
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Makes File and Folder names Windows compatible
'History
'Date Author Changes
'2013-08-13 Philipp Post Initial Version
'Comments: Used in Save_Outlook_Mails_To_Disk
'Readings: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx
'--------------------------------------------------------------------------------------------------
Function Clean_Mail_Filename(filename As String) As String
Dim replacing_char As String
On Error GoTo error_handler
'Set the replacement char here
replacing_char = ""
'Remove RE, FW, Fwd, AW
filename = Replace(filename, "RE: ", replacing_char)
filename = Replace(filename, "RE:", replacing_char)
filename = Replace(filename, "FW: ", replacing_char)
filename = Replace(filename, "FW:", replacing_char)
filename = Replace(filename, "Fwd: ", replacing_char)
filename = Replace(filename, "Fwd:", replacing_char)
filename = Replace(filename, "AW: ", replacing_char)
filename = Replace(filename, "AW:", replacing_char)
'Remove double whitespaces
filename = Replace(filename, " ", " ")
'Replace single whitespaces with underscores
filename = Replace(filename, " ", "_")
'Any files or folders with these chars in it will not be created:
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)
Clean_Mail_Filename = filename
Exit Function
error_handler:
Clean_Mail_Filename = ""
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in function Clean_Mail_Filename"
End Function
Thanks for sharing! A text file containing the code is available here.
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, "", ""), _
":", ""), _
"""", ""), _
"/", ""), _
"|", ""), _
"?", ""), _
"*", "")
try adding a second ) after the very last one.
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?
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 http://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)
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)
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.
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. :)
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
Option Explicit
'--------------------------------------------------------------------------------------------------
'Description: Saves all Messages out of the selected Outlook folder to the Hard Drive
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change to work inside Excel, bug fixes, change naming convention
'2013-09-14 Philipp Post Fix double \\ within file path, change char replacment function
'Comments: Does NOT need reference to Microsoft Outlook 12.0 Object Library
' Use of late binding. Needs to declare all Outlook specific types as Variant
' and use CreateObject("Outlook.Application") as in case of missing Outlook Libraries
' the whole vba app stops working
'Readings: Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
' Late Binding: http://msdn.microsoft.com/en-us/library/office/ff865816.aspx
' Save As Types: http://msdn.microsoft.com/en-us/library/office/bb175283(v=office.12).aspx
' Outlook access security: http://www.outlookcode.com/article.aspx?ID=52
' Disable Security prompt in OL2007: Tools->Trust Center->Programmatic Access->Never warn me...
'--------------------------------------------------------------------------------------------------
Sub Save_Outlook_Mails_To_Disk()
Dim outlook_app As Object 'Outlook.Application
Dim outlook_mail_item As Variant 'MailItem
Dim folder_counter As Long
Dim folder_mail_counter As Long
Dim outlook_folders As New Collection
Dim outlook_entry_ids As New Collection
Dim outlook_store_ids As New Collection
Dim outlook_start_folder As Object
Dim outlook_folder As Variant 'MAPIFolder
Dim outlook_folder_path As String
Dim outlook_folder_path_strip_length As Integer
Dim disk_root_path As String
Dim disk_folder_path As String
Dim mail_subject As String
Dim mail_filename As String
Dim mail_file_fullname As String
Dim mail_received_time As String
Dim mail_counter As Long
'For Folder open dialogue
Dim shell_app As Object
Dim folder_obj As Object
On Error GoTo error_handler
Set outlook_app = CreateObject("Outlook.Application")
mail_counter = 0
'Select the Outlook Folder to save to disk
'Opens a folder picker popup window
Set outlook_start_folder = outlook_app.GetNamespace("MAPI").PickFolder
'User canceled folder selection
If outlook_start_folder Is Nothing Then
Exit Sub
End If
'Obtain the save to disk root folder
'Opens a folder picker popup window
Set shell_app = CreateObject("Shell.Application")
'With start folder set
'Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0, "U:\Folder\")
'Without start folder set
Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0)
'User canceled folder selection
If folder_obj Is Nothing Then
Exit Sub
End If
disk_root_path = folder_obj.self.Path
'Fill the outlook folder structures
Call Get_Outlook_Folders(outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_start_folder)
'Go through all folders
For folder_counter = 1 To outlook_folders.Count
outlook_folder_path = outlook_folders(folder_counter)
'Clean out invalid chars
'(do NOT clean out the backslash \ as it is needed for the folder structure)
outlook_folder_path = Remove_Illegal_Characters(outlook_folder_path, True)
If folder_counter = 1 Then
'Put the selected folder name to the disk
'outlook_folder_path_strip_length = Len(outlook_folder_path) - Len(outlook_start_folder) + 1
'Do not put the selected Outlook folder name to disk
outlook_folder_path_strip_length = Len(outlook_folder_path) + 1
End If
outlook_folder_path = Mid(outlook_folder_path, outlook_folder_path_strip_length)
disk_folder_path = disk_root_path & outlook_folder_path & "\"
'Create directory if missing
'Cannot create a directory tree in one go (folder + subfolder)
'Just one hierarchy item at a time
If Dir(disk_folder_path, vbDirectory) = "" Then
MkDir (disk_folder_path)
End If
Set outlook_folder = outlook_app.Session.GetFolderFromID(outlook_entry_ids(folder_counter), outlook_store_ids(folder_counter))
'Go through all mail items in the present folder
For folder_mail_counter = 1 To outlook_folder.Items.Count
Set outlook_mail_item = outlook_folder.Items(folder_mail_counter)
mail_counter = mail_counter + 1
mail_received_time = Format(outlook_mail_item.ReceivedTime, "YYYY-MM-DD_hhmm")
'shorten overlong mail subjects
mail_subject = Left(outlook_mail_item.Subject, 100)
If mail_subject = "" Then mail_subject = "No Subject"
mail_filename = Remove_Illegal_Characters(mail_subject)
mail_file_fullname = disk_folder_path & mail_filename & "_" & mail_received_time & "_" & mail_counter & ".msg"
'OlSaveAsType Constants (must also change the file extension)
'olTXT = 0 / olRTF = 1 / olTemplate = 2 / olMSG = 3 / olDoc = 4
'0 and 3 work with any message, the other formats do not
outlook_mail_item.SaveAs mail_file_fullname, 3
Next
Next
MsgBox mail_counter & " mails saved to disk.", vbInformation, "Save Outlook Messages To Disk"
Exit Sub
error_handler:
If Err.Number = 287 Then
MsgBox "Access to Outlook was denied.", vbCritical, "Error accessing Outlook"
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk"
End If
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Fills the passed variables with Outlook Folder structures
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change naming conventions
'Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
'Comments: Calls itself recursively to get the full folder tree
' Needed for Save_Outlook_Mails_To_Disk
'--------------------------------------------------------------------------------------------------
Sub Get_Outlook_Folders(outlook_folders As Collection, outlook_entry_ids As Collection, outlook_store_ids As Collection, outlook_current_folder As Variant)
Dim outlook_subfolder As Variant 'MAPIFolder
On Error GoTo error_handler
outlook_folders.Add outlook_current_folder.FolderPath
outlook_entry_ids.Add outlook_current_folder.EntryID
outlook_store_ids.Add outlook_current_folder.StoreID
For Each outlook_subfolder In outlook_current_folder.Folders
Get_Outlook_Folders outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_subfolder
Next
Set outlook_subfolder = Nothing
Exit Sub
error_handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Get_Outlook_Folders"
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Makes File and Folder names Windows compatible
'History
'Date Author Changes
'2013-08-13 Philipp Post Initial Version
'2013-09-14 Philipp Post Change to REGEX usage
'Comments: Used in Save_Outlook_Mails_To_Disk
' Any files or folders with these chars in it will not be created :"/\|?*
' However in case of paths (without the drive) the backslash must remain.
' Set keep_backslash to TRUE to do so.
'Readings: Invalid Filesystem chars: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx
' REGEX general: http://en.wikipedia.org/wiki/Regular_expression
' REGEX in vbscript: http://msdn.microsoft.com/en-us/library/ms974570.aspx
' Alternative with array: http://windowssecrets.com/forums/showthread.php/60041-Invalid-Charaters-(VBA)
'--------------------------------------------------------------------------------------------------
Function Remove_Illegal_Characters(uncleaned_string As String, Optional keep_backslash As Boolean = False) As String
Dim result As String
On Error GoTo error_handler
result = uncleaned_string
With CreateObject("vbscript.regexp")
.Global = True
.IgnoreCase = True
'1) Remove RE, FW, Fwd, AW
' The pipe | sign is the separator to add more patterns
.Pattern = "RE:|FW:|Fwd:|AW:"
result = .Replace(result, "")
'2) Replace slash (often occurs within mail subjects, e.g. US dates) with hyphen
.Pattern = "[\/]+"
result = .Replace(result, "-")
'3) Remove one or more (= regex +) chars which are NOT one of these:
' a-z A-Z _ 0-9 (= regex ^\w), hyphens and white spaces
' To allow other chars, change the regex like this: [^\w\.@-\\]
' which means: remove non word characters and keep .@- and \
If keep_backslash Then
'Allow backslash: add \\
.Pattern = "[^\w\- \\]+"
Else
.Pattern = "[^\w\- ]+"
End If
result = .Replace(result, "")
'4) Remove leading and trailing white spaces or tabs (TRIM)
' (we could remove tabs \t from here as this is covered in 3) already)
.Pattern = "^[ \t]+|[ \t]+$"
result = .Replace(result, "")
'5) Replace one or more whitespaces or tabs within the text with one underscore
.Pattern = "[ \t]+"
result = .Replace(result, "_")
End With
Remove_Illegal_Characters = result
Exit Function
error_handler:
Remove_Illegal_Characters = ""
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in function Remove_Illegal_Characters"
End Function
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!
Is the message signed? What attachments are on the message? Do they have special characters in the the filename?
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!
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.
The error occurs every time it encounters a read receipt.
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
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.
Option Explicit
'--------------------------------------------------------------------------------------------------
'Description: Saves all Messages out of the selected Outlook folder to the Hard Drive
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change to work inside Excel, bug fixes, change naming convention
'2013-09-14 Philipp Post Fix double \\ within file path, change char replacment function
'2013-09-16 Philipp Post Add PDF Export and Attachment saving
'2013-09-28 Philipp Post Fix Bug when saving Read Confirmations
'Comments: Does NOT need reference to Microsoft Outlook 12.0 Object Library
' Use of late binding. Needs to declare all Outlook specific types as Variant
' and use CreateObject("Outlook.Application") as in case of missing Outlook Libraries
' the whole vba app stops working
'Readings: Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
' Late Binding: http://msdn.microsoft.com/en-us/library/office/ff865816.aspx
' Save As Types: http://msdn.microsoft.com/en-us/library/office/bb175283(v=office.12).aspx
' http://www.access-im-unternehmen.de/fileadmin/download/OutlookEnumerationen.txt
' Outlook access security: http://www.outlookcode.com/article.aspx?ID=52
' Disable Security prompt in OL2007: Tools->Trust Center->Programmatic Access->Never warn me...
' File Name and Path lenght: http://msdn.microsoft.com/en-us/library/aa365247.aspx
' Save Mail as PDF: http://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/
' Downside of Word PDF: slow, no pictures saved, file size bigger than with Acrobat
' Word constants: http://www.visualbasicscript.com/rss-m73963.ashx
'--------------------------------------------------------------------------------------------------
Sub Save_Outlook_Mails_To_Disk()
Dim outlook_app As Object 'Outlook.Application
Dim outlook_mail_item As Variant 'MailItem
Dim folder_counter As Long
Dim folder_mail_counter As Long
Dim outlook_folders As New Collection
Dim outlook_entry_ids As New Collection
Dim outlook_store_ids As New Collection
Dim outlook_start_folder As Object
Dim outlook_folder As Variant 'MAPIFolder
Dim outlook_folder_path As String
Dim outlook_folder_path_strip_length As Integer
Dim disk_root_path As String
Dim disk_folder_path As String
Dim mail_subject As String
Dim mail_filename As String
Dim mail_file_fullname As String
Dim temp_mail_file_fullname As String
Dim mail_received_time As String
Dim mail_counter As Long
Dim mail_file_type As String
Dim mail_attachment_counter As Long
Dim mail_attachment_filename As String
Dim mail_attachment_extension As String
'For Folder open dialogue
Dim shell_app As Object
Dim folder_obj As Object
'For PDF conversion
Dim word_app As Object 'Word.Application
Dim word_document As Variant 'Word.Document
On Error GoTo error_handler
Set outlook_app = CreateObject("Outlook.Application")
mail_counter = 0
'Change the export format here
'-----------------------------
'Allowed file types: txt, msg, mht, pdf
'These work with any message, the other formats (RTF, HTML) do not.
'Recommended is 'msg'. PDF is VERY slow on lots of messages.
mail_file_type = "msg"
'Select the Outlook Folder to save to disk
'Opens a folder picker popup window
Set outlook_start_folder = outlook_app.GetNamespace("MAPI").PickFolder
'User canceled folder selection
If outlook_start_folder Is Nothing Then
Exit Sub
End If
'Obtain the save to disk root folder
'Opens a folder picker popup window
Set shell_app = CreateObject("Shell.Application")
'With start folder set
'Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0, "U:\RHH0T322 - GTM\")
'Without start folder set
Set folder_obj = shell_app.BrowseForFolder(0, "Please choose a folder where the mails should be saved to.", 0)
'If called within Excel 2007 on Win7 , the folder selection window is not the topmost window - press ALT-TAB to display it
'SendKeys ("%{TAB}")
'User canceled folder selection
If folder_obj Is Nothing Then
Exit Sub
End If
disk_root_path = folder_obj.self.Path
'Initialize Word for PDF conversion if necessary
If mail_file_type = "pdf" Then
Set word_app = CreateObject("Word.Application")
End If
'Fill the outlook folder structures
Call Get_Outlook_Folders(outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_start_folder)
'Go through all folders
For folder_counter = 1 To outlook_folders.Count
outlook_folder_path = outlook_folders(folder_counter)
'Clean out invalid chars
'(do NOT clean out the backslash \ as it is needed for the folder structure)
outlook_folder_path = Remove_Illegal_Characters(outlook_folder_path, True)
If folder_counter = 1 Then
'Put the selected folder name to the disk
'outlook_folder_path_strip_length = Len(outlook_folder_path) - Len(outlook_start_folder) + 1
'Do not put the selected Outlook folder name to disk
outlook_folder_path_strip_length = Len(outlook_folder_path) + 1
End If
outlook_folder_path = Mid(outlook_folder_path, outlook_folder_path_strip_length)
disk_folder_path = disk_root_path & outlook_folder_path & "\"
'Create directory if missing
'Cannot create a directory tree in one go (folder + subfolder)
'Just one hierarchy item at a time
If Dir(disk_folder_path, vbDirectory) = "" Then
MkDir (disk_folder_path)
End If
Set outlook_folder = outlook_app.Session.GetFolderFromID(outlook_entry_ids(folder_counter), outlook_store_ids(folder_counter))
'Go through all mail items in the present folder
For folder_mail_counter = 1 To outlook_folder.Items.Count
Set outlook_mail_item = outlook_folder.Items(folder_mail_counter)
mail_counter = mail_counter + 1
'Read confirmations do not support the .ReceivedTime property and create the
'exception "Object doesn't support this property or method (438)"
'Exclude them from requesting the ReceivedTime
If outlook_mail_item.MessageClass = "Report.IPM.Note.IPNRN" Then
mail_received_time = ""
Else
mail_received_time = Format(outlook_mail_item.ReceivedTime, "YYYY-MM-DD_hhmm")
End If
'Shorten overlong mail subjects
'(A file or folder name must be limited to 255 chars,
' the full path to 32.767 chars, but recommended is 260 chars)
mail_subject = Left(outlook_mail_item.Subject, 100)
mail_filename = Remove_Illegal_Characters(mail_subject)
'If the subject did just contain illegal characters or no text at all, create a file name
If mail_filename = "" Then mail_filename = "E-Mail"
mail_file_fullname = disk_folder_path & mail_filename & "_" & mail_received_time & "_" & mail_counter
'for PDF only
temp_mail_file_fullname = Environ("temp") & "\" & mail_filename & "_" & mail_received_time & "_" & mail_counter
'Save the mail based on the selected format
Select Case mail_file_type
Case "txt"
outlook_mail_item.SaveAs mail_file_fullname & ".txt", 0
Case "msg"
outlook_mail_item.SaveAs mail_file_fullname & ".msg", 3
Case "mht"
outlook_mail_item.SaveAs mail_file_fullname & ".mht", 10
Case "pdf"
'Save as temporary mht
outlook_mail_item.SaveAs temp_mail_file_fullname & ".mht", 10
'Convert to pdf (Open in MS Word and save as PDF)
Set word_document = word_app.Documents.Open(filename:=temp_mail_file_fullname & ".mht", Visible:=True)
'CreateBookmarks:=0 (wdExportCreateNoBookmarks)
'CreateBookmarks:=1 (wdExportCreateHeadingBookmarks)
word_app.ActiveDocument.ExportAsFixedFormat _
OutputFileName:=mail_file_fullname & ".pdf", _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=1, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
word_document.Close
'Remove the temporary mht file
Kill temp_mail_file_fullname & ".mht"
Case Else
MsgBox "Unknown export file type '" & mail_file_type & "'", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk"
Exit Sub
End Select
'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
Next
Next
'Close Word if necessary
If mail_file_type = "pdf" Then
word_app.Quit
End If
MsgBox mail_counter & " mails saved to disk.", vbInformation, "Save Outlook Messages To Disk"
Exit Sub
error_handler:
If Err.Number = 287 Then
MsgBox "Access to Outlook was denied.", vbCritical, "Error accessing Outlook"
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Save_Outlook_Messages_To_Disk"
End If
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Fills the passed variables with Outlook Folder structures
'History
'Date Author Changes
'2013-06-19 Diane Poremsky Initial Version
'2013-08-13 Philipp Post Change naming conventions
'Source: http://www.slipstick.com/developer/saving-messages-to-the-hard-drive-using-vba/
'Comments: Calls itself recursively to get the full folder tree
' Needed for Save_Outlook_Mails_To_Disk
'--------------------------------------------------------------------------------------------------
Sub Get_Outlook_Folders(outlook_folders As Collection, outlook_entry_ids As Collection, outlook_store_ids As Collection, outlook_current_folder As Variant)
Dim outlook_subfolder As Variant 'MAPIFolder
On Error GoTo error_handler
outlook_folders.Add outlook_current_folder.FolderPath
outlook_entry_ids.Add outlook_current_folder.EntryID
outlook_store_ids.Add outlook_current_folder.StoreID
For Each outlook_subfolder In outlook_current_folder.Folders
Get_Outlook_Folders outlook_folders, outlook_entry_ids, outlook_store_ids, outlook_subfolder
Next
Set outlook_subfolder = Nothing
Exit Sub
error_handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in procedure Get_Outlook_Folders"
End Sub
'--------------------------------------------------------------------------------------------------
'Description: Makes File and Folder names Windows compatible
'History
'Date Author Changes
'2013-08-13 Philipp Post Initial Version
'2013-09-14 Philipp Post Change to REGEX usage
'2013-09-15 Philipp Post Add diacritcs replacement and Sharepoint exceptions
'Comments: Used in Save_Outlook_Mails_To_Disk
' Any files or folders in Windows with these chars will not be created :"/\|?*
' MS Sharepoint additionally rejects these: ~#%+.
' However in case of paths (without the drive) the backslash must remain.
' Set keep_backslash to TRUE to do so.
'Readings: Invalid Filesystem chars: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx
' Invalid Sharepoint chars: http://support.microsoft.com/kb/905231/en-us
' REGEX general: http://en.wikipedia.org/wiki/Regular_expression
' REGEX in vbscript: http://msdn.microsoft.com/en-us/library/ms974570.aspx
' Alternative with array: http://windowssecrets.com/forums/showthread.php/60041-Invalid-Charaters-(VBA)
'--------------------------------------------------------------------------------------------------
Function Remove_Illegal_Characters(uncleaned_string As String, Optional keep_backslash As Boolean = False) As String
Dim result As String
On Error GoTo error_handler
result = uncleaned_string
With CreateObject("vbscript.regexp")
.Global = True
'1) Remove RE, FW, Fwd, AW
' The pipe | sign is the separator to add more patterns
.IgnoreCase = True
.Pattern = "RE:|FW:|Fwd:|AW:"
result = .Replace(result, "")
'2) Replace slash (/) which often occurs within mail subjects, e. g. US dates,
' ampersand (&), plus (+) with hyphen (-)
.Pattern = "[\/\&\+]+"
result = .Replace(result, "-")
'3) Replace diacritics
.IgnoreCase = False
' Uppercase letters
.Pattern = "[ÀÁÂÃÄÆÅ]"
result = .Replace(result, "A")
.Pattern = "[Ç]"
result = .Replace(result, "C")
.Pattern = "[ÈÉÊË]"
result = .Replace(result, "E")
.Pattern = "[ÌÍÎÏ]"
result = .Replace(result, "I")
.Pattern = "[Ñ]"
result = .Replace(result, "N")
.Pattern = "[ÒÓÔÕÖØ]"
result = .Replace(result, "O")
.Pattern = "[ÙÚÛÜ]"
result = .Replace(result, "U")
.Pattern = "[Ý]"
result = .Replace(result, "Y")
' Lowercase letters
.Pattern = "[àáâãäæå]"
result = .Replace(result, "a")
.Pattern = "[ç]"
result = .Replace(result, "c")
.Pattern = "[èéêë]"
result = .Replace(result, "e")
.Pattern = "[ìíîï]"
result = .Replace(result, "i")
.Pattern = "[ñ]"
result = .Replace(result, "n")
.Pattern = "[òóôõöø]"
result = .Replace(result, "o")
.Pattern = "[ùúûü]"
result = .Replace(result, "u")
.Pattern = "[ýÿ]"
result = .Replace(result, "y")
.Pattern = "[ß]"
result = .Replace(result, "ss")
'4) Remove one or more (= regex +) chars which are NOT one of these:
' a-z A-Z _ 0-9 (= regex ^\w), hyphens (-) and white spaces
' To allow other chars, change the regex like this: [^\w\.@-\\]
' which means: remove non word characters and keep .@- and \
If keep_backslash Then
'Allow backslash: add \\
.Pattern = "[^\w\- \\]+"
'use this if you must allow non latin chars (removes just special chars in the list)
'.Pattern = "[\""""\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\\?\/\,]"
Else
.Pattern = "[^\w\- ]+"
'use this if you must allow non latin chars (removes just special chars in the list)
'.Pattern = "[\""""\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\\?\/\,\\]"
End If
result = .Replace(result, "")
'5) Remove leading and trailing white spaces or tabs (TRIM)
' (we could remove tabs \t from here as this is covered in 4) already)
.Pattern = "^[ \t]+|[ \t]+$"
result = .Replace(result, "")
'6) Replace one or more whitespaces or tabs within the text with one underscore
.Pattern = "[ \t]+"
result = .Replace(result, "_")
'7) Remove invalid file or folder name endings for Sharepoint
.Pattern = "\.files$|_files$|-Dateien$|_fichiers$|_bestanden$|_file$|_archivos$|" & _
"-filer$|_tiedostot$|_pliki$|_soubory$|_elemei$|_ficheiros$|_arquivos$|" & _
"_dosyalar$|_datoteke$|_fitxers$|_failid$|_fails$|_bylos$|_fajlovi$|_fitxategiak"
result = .Replace(result, "")
End With
Remove_Illegal_Characters = result
Exit Function
error_handler:
Remove_Illegal_Characters = ""
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "Error in function Remove_Illegal_Characters"
End Function
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.
Shouldn't
disk_folder_path = disk_root_path & outlook_folder_path & "\"
be
disk_folder_path = disk_root_path & "\" & outlook_folder_path & "\"
it depends if the disk_root_path has the ending \.
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
It uses FSO, so if it works in excel, it will work in Outlook. What error message do you get?
Compile error:
variable not defined
with myobject highlighted.
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.
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!
Thanks for the update. I'll leave the other posts, it may help someone who is having problems getting their code to work.
There's a wee typo here in Phillips post
If mail_file_type "msg" Then
should this be
If mail_file_type = "msg" Then
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
===================================================================
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
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.
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:
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
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.
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".)
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.
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.
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?
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"
Thanks a million for the assistance. I will give it a try in the morning.
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.)
Sent messages will be your name - see http://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.