Excel VBA loop through emails in inbox folders and save messages to local address

Question

I was trying to use VBA to loop through all the subfolders of my inbox(Some subfolders contain emails, while some do not), and then save all the emails to a folder on my computer.

The macro was able to save some emails in the subfolders, but not all. And then the macro stopped at one subfolder and gave an error message "Runtime error '-2147287037(80030003)':The operation failed'.

Can anyone please help me understand what was wrong? Thank you!

Below is my code.

Sub Savemails()
Application.ScreenUpdating = False

Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Object
Dim savePath As String
Dim user_mail As String
Dim Folder As Outlook.MAPIFolder
Dim mItem As Object

Application.DisplayAlerts = False

user_mail = ThisWorkbook.Worksheets("Sheet1").Range("EmailAddress").Value

Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.Folders(user_mail).Folders("inbox")

savePath = "C:\Users\yangrach\Desktop\emails\2022\"

For Each Folder In olFolder.Folders
   For Each mItem In Folder.Items 
       If mItem.Class = OlObjectClass.olMail Then
          mItem.SaveAs savePath & mItem.Subject & ".msg"
       End If
   Next mItem
Next Folder

Application.ScreenUpdating = True

End Sub

The runtime error can be caused due to invalid characters in the email subject e.g. a date that contains slashes `/`. — Kostas K., Nov 23 '22 at 16:37

score 1 · Accepted Answer · answered Nov 23 '22 at 23:27

First of all, you need to make sure that you deal with a valid file path, see What characters are forbidden in Windows and Linux directory names? for more information. The Subject property may contain forbidden symbols, so you may try using the following function to fix the file path and make sure the file name and path is valid:

Function FixFileName(FileName As String) As String
  Dim fname As String

  fname = Trim(FileName)

  fname = Replace(fname, " ", "_")
  fname = Replace(fname, ",", "")
  fname = Replace(fname, "'", "")
  fname = Replace(fname, "(", "")
  fname = Replace(fname, ")", "")
  fname = Replace(fname, "~", "")
  fname = Replace(fname, "*", "")
  fname = Replace(fname, "?", "")
  fname = Replace(fname, "/", "")
  fname = Replace(fname, "\", "")
  fname = Replace(fname, """", ""  )

  FixFileName = fname

End Function

Excel VBA loop through emails in inbox folders and save messages to local address

1 Answers1