none
(oultook 2007) VB script to Save emails on HDD

    Question

  • 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!

     
    Monday, March 05, 2012 11:44 AM

Answers

All replies