(oultook 2007) VB script to Save emails on HDD

• Monday, March 05, 2012 11:44 AM

   

   
  

  0

  I've managed to patch together some scripts over the web so i can save emails with a specific naming sequence on the HDD (if the emails are in inbox then the naming squence should be X and if the emails are in sent items the naming sequence is Y) and it works very well...if you don't have subfolders... when an inbox has Sub folders then the script totally ignores the emails in the sub folders. I need to find out how i can apply the same rules in the sub folders

  script is 

  
  
  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 StrFolderName   As String
      Dim StrSaveFolder   As String
      Dim StrSenderName   As String
      Dim StrTo           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))
           
          For j = 1 To SubFolder.Items.Count
              Set mItem = SubFolder.Items(j)
              StrReceived = ArrangedDate(mItem.ReceivedTime)
              StrSubject = mItem.Subject
              StrName = StripIllegalChar(StrSubject)
              StrFolderName = SubFolder.Name
              StrFolderName = StripIllegalChar(StrFolderName)
              StrSenderName = mItem.SenderName
              StrSenderName = StripIllegalChar(StrSenderName)
              StrTo = mItem.To
              StrTo = StripIllegalChar(StrTo)
              If LCase(StrFolderName) = "inbox" Then
                  StrFile = StrSaveFolder & "e-from_" & StrSenderName & "_" & StrReceived & "_re_" & StrName & ".msg"
              ElseIf LCase(StrFolderName) = "sent items" Then
                  StrFile = StrSaveFolder & "e-to_" & StrTo & "_" & StrReceived & "_re_" & StrName & ".msg"
              End If
               
              StrFile = Left(StrFile, 256)
              mItem.SaveAs StrFile, 3
          Next j
           
      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 = Left(StrFullTime, 6) & StrAMPM
      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)
       
       
      BrowseForFolder = ShellApp.self.Path
       
       
      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
  
  

  Please help!

   
  • Reply
  • Quote