Save Email to Computer

Option Explicit 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 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 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 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 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 = ArrangedDate(mItem.ReceivedTime) 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 Function ArrangedDate(StrDateInput) Dim StrFullDate As String Dim StrFullTime As String Dim StrAMPM As String Dim StrTime As String Dim StrYear As String Dim StrMonthDay As String Dim StrMonth As String Dim StrDay As String Dim StrDate As String Dim StrDateTime As String Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") If Not Left(StrDateInput, 2) = "10" And _ Not Left(StrDateInput, 2) = "11" And _ Not Left(StrDateInput, 2) = "12" Then StrDateInput = "0" & StrDateInput End If StrFullDate = Left(StrDateInput, 10) If Right(StrFullDate, 1) = " " Then StrFullDate = Left(StrDateInput, 9) End If StrFullTime = Replace(StrDateInput, StrFullDate & " ", "") If Len(StrFullTime) = 10 Then StrFullTime = "0" & StrFullTime End If StrAMPM = Right(StrFullTime, 2) StrTime = StrAMPM & "-" & Left(StrFullTime, 8) StrYear = Right(StrFullDate, 4) StrMonthDay = Replace(StrFullDate, "/" & StrYear, "") StrMonth = Left(StrMonthDay, 2) StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3) If Len(StrDay) = 1 Then StrDay = "0" & StrDay End If StrDate = StrYear & "-" & StrMonth & "-" & StrDay StrDateTime = StrDate & "_" & StrTime RegX.Pattern = "[\:\/\ ]" RegX.IgnoreCase = True RegX.Global = True ArrangedDate = RegX.Replace(StrDateTime, "-") ExitFunction: Set RegX = Nothing End Function Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder) Dim SubFolder As MAPIFolder Folders.Add Fld.FolderPath EntryID.Add Fld.EntryID StoreID.Add Fld.StoreID For Each SubFolder In Fld.Folders GetFolder Folders, EntryID, StoreID, SubFolder Next SubFolder ExitSub: Set SubFolder = Nothing End Sub Function BrowseForFolder(Optional OpenAt As String) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then BrowseForFolder = "" End If Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then BrowseForFolder = "" End If Case Else BrowseForFolder = "" End Select ExitFunction: Set ShellApp = Nothing End Function