Microsoft Office Forums - View Single Post - [Solved] Saving group of individual e-mails

gmayor · 06-12-2016, 02:36 AM

You can certainly process all the folders under your default inbox, which I think is what you are asking. It needs a further macro to process the folders (which becomes the main macro) and some modifications to the ProcessFolder macro (see below) to take the input from the new macro (the other functions are still required).

You will notice I have added some commented out lines in the ProcessFolder sub. If restored, these lines add a category to each processed message, so that next time the process is run, the process checks for the added category and if present, the categorised messages will not be processed again.

Code:

Option Explicit

Sub SaveMessages()
'Graham Mayor - http://www.gmayor.com
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace
Dim strPath As String
Dim sSubPath As String
Dim sStore As String

    strPath = InputBox("Enter the path to save the messages." & vbCr & _
                       "The path will be created if it doesn't exist.", _
                       "Save Message", "C:\Outlook Message Backup\")

    Do Until Right(strPath, 1) = Chr(92)
        strPath = strPath & Chr(92)
    Loop

    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        sStore = olFolder.Store
        sSubPath = Replace(olFolder.FolderPath, "\\" & sStore & "\", strPath)
        CreateFolders sSubPath
        ProcessFolder olFolder, sSubPath
        If olFolder.folders.Count > 0 Then
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        End If
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Exit Sub
End Sub

Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String)
'Graham Mayor - http://www.gmayor.com
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim i As Long
Dim ofrm As New frmProgress
Dim PortionDone As Double

    On Error GoTo err_Handler

    Set olItems = olMailFolder.Items
    ofrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        'If Not olMailItem.categories = "Backed-up To File" Then
            PortionDone = i / olItems.Count
            ofrm.Caption = olMailFolder.Name & " - Processing " & i & " of " & olItems.Count
            ofrm.lblProgress.Width = ofrm.fmeProgress.Width * PortionDone
            SaveMessage olMailItem, sPath
            'olMailItem.categories = "Backed-up To File"
            'olMailItem.Save
            DoEvents
        'End If
    Next olMailItem
    Unload ofrm
lbl_Exit:
    Set ofrm = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub