Consulting

Results 1 to 7 of 7

Thread: Saving e-mail messages to folder

  1. #1
    VBAX Tutor
    Joined
    Jul 2009
    Posts
    207
    Location

    Saving e-mail messages to folder

    Using this code off your site http://www.vbaexpress.com/kb/getarticle.php?kb_id=875 courtesy of Jacob Hilderbrand I am able to achieve transferring outlook messages to a folder on my PC.

    2 things I am having problems with are

    1. What do the numbers that are added to the file name mean i.e. -201-02--07-201_00-023-07-2_test1.

    test1 is the file name but the macro adds -201-02--07-201_00-023-07-2_. I don't understand what this represents. What do I need to change to just add the date received in dd.mm.yyyy format.

    2. I can save the messages locally but not over a network to a NAS.

    As an additional thought is it possible to select messages from a folder instead of the whole folder contents.

    I have tried deleting various bits but haven't had any success yet. Any help would be appreciated.

    Sorry to post the whole script.



    Option Explicit 
    
    
     
    Sub SaveAllEmails_ProcessAllSubFolders()
         
        Dim i               As Long
        Dim j               As Long
        Dim n               As Long
        Dim k               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 ' <-- I suggest you comment this out when debugging
    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)
    
    
    StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & ".msg"
    
    
    k = 0 ' <--- i is already being used
    JumpHere:
    If Dir(StrFile) = "" Then
    mItem.SaveAs StrFile, 3
    Else
    k = k + 1
    StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & k & ".msg"
    GoTo JumpHere
    End If
    
    
    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

  2. #2
    The following, versions of which I have posted before, will save selected messages as text files to a folder (including a network folder) in the format
    yyyymmdd HH.MM" SenderName - Subject.msg.

    By including the time. you minimise the number of duplicated files produced (no files are overwritten), but you can remove the time from the fName definitions if you wish.

    You will need to change the domain name to your own domain name in order to save messages that you have sent.


    Option Explicit
    
    Sub SaveSelectedMessages()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Saves the currently selected messages
    Dim sPath As String
    Dim olItem As MailItem
        sPath = BrowseForFolder
        If sPath = "" Then
            Beep
            GoTo lbl_Exit
        End If
        Do Until Right(sPath, 1) = Chr(92)
            sPath = sPath & Chr(92)
        Loop
        For Each olItem In Application.ActiveExplorer.Selection
            If olItem.Class = OlObjectClass.olMail Then
                SaveItem olItem, sPath
            End If
        Next olItem
    lbl_Exit:
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    
    Private Sub SaveItem(olItem As MailItem, strPath As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'The main macro called by the above macros.
    Dim fname As String
    If olItem.sender Like "*@gmayor.com" Then    'Your domain
            fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        Else
            fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        End If
        fname = Replace(fname, Chr(58) & Chr(41), "")
        fname = Replace(fname, Chr(58) & Chr(40), "")
        fname = Replace(fname, Chr(34), "-")
        fname = Replace(fname, Chr(42), "-")
        fname = Replace(fname, Chr(47), "-")
        fname = Replace(fname, Chr(58), "-")
        fname = Replace(fname, Chr(60), "-")
        fname = Replace(fname, Chr(62), "-")
        fname = Replace(fname, Chr(63), "-")
        fname = Replace(fname, Chr(92), "-")
        fname = Replace(fname, Chr(124), "-")
        On Error GoTo err_Handler
        SaveUnique olItem, strPath, fname
    lbl_Exit:
        Exit Sub
    err_Handler:
        WriteToLog strPath & "Error Log.txt", strPath & fname
        Err.Clear
        GoTo lbl_Exit
    End Sub
    
    
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Ensures that filenames are not overwritten
    Dim lngF As Long
    Dim lngName As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While FSO.FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        oItem.SaveAs strPath & strFileName & ".msg"
    lbl_Exit:
        Exit Function
    End Function
    
    
    Function BrowseForFolder() As String
    Dim FSO As Object
        Set FSO = CreateObject("Shell.Application"). _
                       BrowseForFolder(0, "Please choose a folder", 0)
        On Error Resume Next
        BrowseForFolder = FSO.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
    lbl_Exit:
        Set FSO = Nothing
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Tutor
    Joined
    Jul 2009
    Posts
    207
    Location
    Hello gmayor,
    Thank you for your reply which I am currently trying to test. I must warn you that I am not a programmer so if my questions sound daft then I apologise in advance.
    I am trying to run the code but am getting an error

    err_Handler:
        WriteToLog strPath & "Error Log.txt", strPath & fname
        Err.Clear
    WriteToLog is highlighted

    A message pops up saying "Compile error: Sub or function not defined"

    Thanks Gil

  4. #4
    Oops - sorry about that, it was part of a larger project that included an error log and I forgot to delete the line
    Simply delete the WriteToLog line.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Tutor
    Joined
    Jul 2009
    Posts
    207
    Location
    Hello gmayor, That tweek worked and all seems to be working ok. Is there a limit the code can handle in one session. Otherwise thank you for your help.

  6. #6
    If the process appears to hang when handling large numbers of messages add the line DoEvents before the line Next olItem otherwise have you had a problem that reflects a limit?

    For Each olItem In Application.ActiveExplorer.Selection        If olItem.Class = OlObjectClass.olMail Then
                SaveItem olItem, sPath
            End If
            DoEvents
        Next olItem
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    VBAX Tutor
    Joined
    Jul 2009
    Posts
    207
    Location
    Hello gmayor, I was just curious about limits. I have been running it with no problems. The most I have done so far is 57 which took about 5-10 seconds. Once again thank you for your help and I will close the thread as complete.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •