Results 1 to 5 of 5

Thread: Save all messages in outlook folder to local folder

  1. #1

    Save all messages in outlook folder to local folder

    So my goal is to select a folder and then run a macro which will go through every item in the selected folder and save each email to a local folder on my hard drive. I've cobbled together the code below, however I can't get it to run correctly. Whenever I run the macro the first message gets saved as itshould and then my outlook freezes and crashes or it will give me a run-timeerror '-2147287037 (80030003)': Operation failed. If I instead select all messages in the folder and just run the SaveMessageAsMsg () function, it works pretty well except that a few emails are getting skipped. For example I justselected 175 items in the outlook folder, ran SaveMessageAsMsg and only 172were saved. I made sure and checked the message class of all the items in thefolder and they are all "IPM.Note" as specified in the code.

    I'm hoping you all will be able to help me with (1) helpingme understand the "BackupEmail" portion of my code is causing outlookto crash or return an error, and (2) help me understand why only 172 out of 175messages are saving when I just run the SaveMessageAsMsg function. And if thereis no fix is there a way to use a MsgBox to tell me exactly which emails needto be manually saved?

  2. #2
    [CODE] Public Sub BackupEmails()
    Dim objOL As Outlook.Application
    Dim objItems As Outlook.Items
    Dim objFolder As Outlook.MAPIFolder
    Dim obj As Object

    Set objOL = Outlook.Application
    Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items

    For Each obj In objItems
    With obj
    Call SaveMessageAsMsg
    End With

    Set obj = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing
    MsgBox "All attachments have been extracted"

    End Sub
    Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Rem Dim enviro As String
    Dim strFolderpath As String

    strFolderpath = "C:\Test\"
    Rem enviro = CStr(Environ("USERPROFILE"))
    For Each objItem In ActiveExplorer.Selection
    If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

    sName = oMail.Subject
    sName = Left(sName, 100)
    ReplaceCharsForFileName sName, "-"

    dtDate = oMail.ReceivedTime
    sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

    sPath = strFolderpath
    Debug.Print sPath & sName
    oMail.SaveAs sPath & sName

    End If

    End Sub

  3. #3

    I also have a function to replace the illegal characters inthe file name but for some reason I'm not allowed to post that portion of thecode because of too many URLs or something?

  4. #4
    Any help would be appreciated!

  5. #5
    The following should work. It will save the message contents of the selected folder and its sub folders in the named folder. Because there can be a lot of messages with little evidence of anything happening it uses a progress indicator which you can download from Import the contents to your Outlook vba editor.

    Option Explicit
    Sub SaveMessages()
    'Graham Mayor - - Last updated - 08 May 2019
    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)
        Set cFolders = New Collection
        Set olNS = GetNamespace("MAPI")
        'cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
        cFolders.Add olNS.PickFolder
        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
        Set olFolder = Nothing
        Set SubFolder = Nothing
        Exit Sub
    End Sub
    Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String)
    'Graham Mayor -
    Dim olItems As Outlook.Items
    Dim olMailItem As Object
    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 TypeName(olMailItem) = "MailItem" Then
                '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"
                'End If
            End If
        Next olMailItem
        Unload oFrm
        Set oFrm = Nothing
        Set olItems = Nothing
        Set olMailItem = Nothing
        Exit Sub
        MsgBox Err.Number & vbCr & Err.Description
        GoTo lbl_Exit
    End Sub
    Private Sub SaveMessage(olItem As MailItem, sPath As String)
    'An Outlook macro by Graham Mayor -
    Dim fname As String
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject
        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(124), "-")
        SaveUnique olItem, sPath, fname
        Exit Sub
    End Sub
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor -
    Dim lngF As Long
    Dim lngName As Long
    Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While oFSO.FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        oItem.SaveAs strPath & strFileName & ".msg"
        Set oFSO = Nothing
        Exit Function
    End Function
    Private Function CreateFolders(strPath As String)
    'An Office macro by Graham Mayor -
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
    Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
        Set oFSO = Nothing
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes

Posting Permissions

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