Saving All Messages to the Hard Drive Using VBA

Last reviewed on December 30, 2013   —  70 comments

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

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

Please post long or more complicated questions at Outlookforums.

70 responses to “Saving All Messages to the Hard Drive Using VBA”

  1. Tom

    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!

  2. Travis

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

  3. Adrian Rutter

    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.

  4. rich

    thanks diane - how can i edit your code to save as .pdf instead of .msg? Thanks!

  5. HS

    Yes.... That is definitely the problem... Any solution?

  6. Nolberto Gaviria

    Thank you very much for sharing your knowledge. God bless you.

  7. M@rtin

    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

  8. M@rtin

    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

  9. M@rtin

    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

  10. Phuc Dinh Cong

    Thank the Author. Here is my debug, it works even not perfect coding

    text file containing macro

  11. Philipp Post

    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

  12. Tony Rockdaschel

    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, "", ""), _
    ":", ""), _
    """", ""), _
    "/", ""), _
    "|", ""), _
    "?", ""), _
    "*", "")

  13. Andrzej

    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?

  14. Tony Rockdaschel

    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.

  15. Philipp Post

    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

  16. Andrzej

    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!

  17. Andrzej

    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!

  18. Philipp Post

    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.

  19. Thom

    The error occurs every time it encounters a read receipt.

  20. Philipp Post

    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

  21. Thom

    Shouldn't
    disk_folder_path = disk_root_path & outlook_folder_path & "\"
    be
    disk_folder_path = disk_root_path & "\" & outlook_folder_path & "\"

  22. eric

    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

  23. eric

    Compile error:

    variable not defined

    with myobject highlighted.

  24. eric

    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.

  25. eric

    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!

  26. Kris

    There's a wee typo here in Phillips post

    If mail_file_type "msg" Then

    should this be

    If mail_file_type = "msg" Then

  27. Kris

    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

    ===================================================================

    1. eric

      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

  28. Kris

    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

  29. JAIME

    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:

  30. Bavaria

    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

  31. Bavaria

    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".)

  32. Bavaria

    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.

  33. Galen

    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?

  34. Galen

    Thanks a million for the assistance. I will give it a try in the morning.

  35. Galen

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

  36. Paddy

    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 (http://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

  37. Paddy

    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?

  38. mhegeral@live.com

    thank you very much. the first worked for me. i just needed to creat the target folder.

  39. santinimatias

    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

  40. Timothy Dollimore

    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.

    http://www.freevbcode.com/ShowCode.asp?ID=1335

    Create an extra module with this in it
    Option Explicit
    'http://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

  41. Timothy Dollimore

    Um, probably shouldn't use // as the inline comment marker for VBA, doh! :-)

Leave a Reply

If the Post Coment button disappears, press your Tab key.