'Save Emails v5.0a - March 31, 2011 Option Explicit Private Type FILETIME LowDateTime As Long HighDateTime As Long End Type Private Type SYSTEMTIME Year As Integer Month As Integer DayOfWeek As Integer Day As Integer Hour As Integer Minute As Integer Second As Integer Milliseconds As Integer End Type 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 SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As Any, lpLastAccessTime As Any, lpLastWriteTime As Any) 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 Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub SaveAllEmails_ProcessAllSubFolders() Dim i As Long Dim j As Long Dim k As Long Dim n As Long Dim junk As Integer Dim ItemCountIn As Long Dim ItemCountOut As Long Dim SaveRetries 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 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 dto As Date Dim dFromDate As Date Dim dToDate As Date Set fso = CreateObject("Scripting.FileSystemObject") Set myOlApp = Outlook.Application Set iNameSpace = myOlApp.GetNamespace("MAPI") ItemCountIn = 0 ItemCountOut = 0 SaveRetries = 0 dto = Now Set ChosenFolder = iNameSpace.PickFolder If ChosenFolder Is Nothing Then GoTo ExitSub: End If Prompt = "Please enter the path to save all the emails to." Title = "Folder Specification" StrSavePath = BrowseForFolder If StrSavePath = "" Then GoTo ExitSub: End If If Not Right(StrSavePath, 1) = "\" Then StrSavePath = StrSavePath & "\" End If ' dFromDate = InputBox("Select how far BACK you want to archive MM/DD/YYYY hh:mm:ss AM/PM", "From Date Selection") ' If dFromDate = Null Then ' GoTo ExitSub: ' End If ' dFromDate = Format(dFromDate, "yyyy-mm-dd_hh-mm-ss") ' dToDate = InputBox("Select the LAST Date you want to archive: MM/DD/YYYY hh:mm:ss AM/PM", "To Date Selection") ' If dToDate = Null Then ' GoTo ExitSub: ' End If ' dToDate = Format(dToDate, "yyyy-mm-dd_hh-mm-ss") Call WriteLog(StrSavePath, "Message Saver v 5.0a Started.") Call WriteLog(StrSavePath, "Starting from Email Folder: " & ChosenFolder) Call WriteLog(StrSavePath, "Saving Messages to Windows Folder: " & StrSavePath) Call WriteLog(StrSavePath, "Saving Messages from: " & dFromDate & " to " & dToDate) Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) ' StrReceived = mItem.ReceivedTime ' If mItem.ReceivedTime > dFromDate And mItem.ReceivedTime < dFromDate Then For i = 1 To Folders.Count StrFolder = StripIllegalFolderChars(Folders(i)) n = InStr(3, StrFolder, "\") + 1 StrFolder = Mid(StrFolder, n, 256) Call WriteLog(StrSavePath, "Processing Messages from: " & StrFolder) StrFolderPath = StrSavePath & StrFolder & "\" StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\" BuildPath StrFolderPath 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) ItemCountIn = ItemCountIn + 1 StrReceived = mItem.ReceivedTime StrReceived = Format(StrReceived, "yyyy-mm-dd_hh-mm-ss") StrSubject = mItem.Subject StrName = StripIllegalFileNameChars(StrSubject) StrFile = StrSaveFolder & StrReceived & "_" & StrName StrFile = Left(StrFile, 240) & ".msg" k = 1 While fso.FileExists(StrFile) StrFile = StrSaveFolder & StrReceived & "_" & StrName StrFile = Left(StrFile, 240) & "(" & k & ").msg" k = k + 1 Wend If mItem.ReceivedTime > dFromDate And mItem.ReceivedTime < dToDate Then mItem.SaveAs StrFile, olMSG Else: Resume Next End If If fso.FileExists(StrFile) Then ItemCountOut = ItemCountOut + 1 Else SaveRetries = SaveRetries + 1 ' Sleep (5000) Sleep (50) mItem.SaveAs StrFile, olMSGUnicode If fso.FileExists(StrFile) Then ItemCountOut = ItemCountOut + 1 Else Call WriteLog(StrSavePath, "ERROR: Failed to save file " & StrFile) End If End If 'Set the creation time FileSetDate StrFile, mItem.ReceivedTime, True 'Set the last accessed time FileSetDate StrFile, mItem.ReceivedTime, , , True Next j On Error GoTo 0 Call WriteLog(StrSavePath, "Done.") Next i Call WriteLog(StrSavePath, "Messages Read: " & ItemCountIn & ", Messages Saved: " & ItemCountOut & ", Retries: " & SaveRetries & ", Failures: " & ItemCountIn - ItemCountOut & ".") Call WriteLog(StrSavePath, "Message Saver Finished.") If ItemCountIn = ItemCountOut Then junk = MsgBox("Message Migration Finished" & vbCrLf & vbCrLf & "Messages Migrated: " & ItemCountIn, vbInformation) Else junk = MsgBox("Message Migration Finished" & vbCrLf & vbCrLf & "Messages Read: " & ItemCountIn & vbCrLf & "Messages Saved: " & ItemCountOut & vbCrLf & vbCrLf & "PLEASE VERIFY YOUR CONTENTS", vbInformation) End If ExitSub: End Sub Function StripIllegalFolderChars(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalFolderChars = Trim(RegX.Replace(StrInput, "")) ExitFunction: Set RegX = Nothing End Function Function StripIllegalFileNameChars(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\x00-\x1F\" & Chr(34) & "\" & Chr(92) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalFileNameChars = Trim(RegX.Replace(StrInput, "")) ExitFunction: Set RegX = Nothing End Function Sub BuildPath(ByVal Path) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(Path) Then BuildPath fso.GetParentFolderName(Path) fso.CreateFolder Path End If End Sub Function FileSetDate(ByVal sFileName As String, ByVal dFileDate As Date, Optional bSetCreationTime As Boolean = False, Optional bSetLastAccessedTime As Boolean = False, Optional bSetLastModified As Boolean = False) As Boolean Const GENERIC_WRITE = &H40000000, OPEN_EXISTING = 3 Const FILE_SHARE_READ = &H1, FILE_SHARE_WRITE = &H2 Dim lhwndFile As Long Dim tSystemTime As SYSTEMTIME Dim tLocalTime As FILETIME, tFileTime As FILETIME tSystemTime.Year = Year(dFileDate) tSystemTime.Month = Month(dFileDate) tSystemTime.Day = Day(dFileDate) tSystemTime.DayOfWeek = Weekday(dFileDate) - 1 tSystemTime.Hour = Hour(dFileDate) tSystemTime.Minute = Minute(dFileDate) tSystemTime.Second = Second(dFileDate) tSystemTime.Milliseconds = 0 'Open the file to get the filehandle lhwndFile = CreateFile(sFileName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0) If lhwndFile Then 'File opened 'Convert system time to local time SystemTimeToFileTime tSystemTime, tLocalTime 'Convert local time to GMT LocalFileTimeToFileTime tLocalTime, tFileTime '-------Change date/time property of the file FileSetDate = True If bSetCreationTime Then FileSetDate = FileSetDate And CBool(SetFileTime(lhwndFile, tFileTime, 0&, 0&)) End If If bSetLastAccessedTime Then FileSetDate = FileSetDate And CBool(SetFileTime(lhwndFile, 0&, tFileTime, 0&)) End If If bSetLastModified Then FileSetDate = FileSetDate And CBool(SetFileTime(lhwndFile, 0&, 0&, tFileTime)) End If 'Close the file handle Call CloseHandle(lhwndFile) End If 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 Sub WriteLog(LogDirectory As String, LogEntry As String) Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim fso, f On Error GoTo ErrHandler Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.OpenTextFile(LogDirectory & "MessageSaver.log", ForAppending, True) f.WriteLine Now() & vbTab & LogEntry ErrHandler: Exit Sub End Sub