Save all messages in outlook folder to local folder

[therion17]

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?

[therion17]

[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
Next

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
Next

End Sub

[therion17]

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?

[therion17]

Any help would be appreciated!

[gmayor]

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 https://www.gmayor.com/Zips/ProgressBar.zip Import the contents to your Outlook vba editor.


Option Explicit

Sub SaveMessages()
'Graham Mayor - https://www.gmayor.com - 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)
Loop


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
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 - https://www.gmayor.com
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"
'olMailItem.Save
DoEvents
'End If
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


Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - https://www.gmayor.com
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
lbl_Exit:
Exit Sub
End Sub


Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - https://www.gmayor.com
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
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function


Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - https://www.gmayor.com
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
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function