Excel VBA 循环浏览收件箱文件夹中的电子邮件并将邮件保存到本地地址[重复]

Question

我试图使用VBA循环遍历收件箱的所有子文件夹（有些子文件夹包含电子邮件，而有些子文件夹不包含），然后将所有电子邮件保存到我计算机上的文件夹中。

宏能够在子文件夹中保存一些电子邮件，但不是全部。然后宏停在一个子文件夹并给出错误消息“运行时错误'-2147287037(80030003)':操作失败'。

任何人都可以帮我理解出了什么问题吗？谢谢！

下面是我的代码。

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

Answer 1

首先，您需要确保处理有效的文件路径，请参阅Windows 和 Linux 目录名称中禁止使用哪些字符？ 了解更多信息。

Subject

属性可能包含禁用符号，因此您可以尝试使用以下函数修复文件路径并确保文件名和路径有效：

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