vba - Saving attachments results in memory errors

还有其他可能性，但我认为内存错误是创建 Word 对象然后没有关闭它们的结果。Om3r 要求提供更多信息，但您忽略了他的要求，因此无法提供明确的答案。但是，我想证明可以毫无问题地从大量电子邮件中提取附件，所以我做了一些猜测。

我理解为什么您需要一个例程来扫描您的收件箱以查找积压的 8,000 封摄像头馈送电子邮件。我不明白您为什么还要使用事件来监视您的收件箱。我不敢相信这是一项时间紧迫的任务。为什么不每天运行一次或两次扫描？但是，我编写的例程可以适用于创建一个由事件例程调用的宏。我当前的代码依赖于全局变量，您必须将其更改为局部变量。我不是全局变量的粉丝，但我不想为内部例程的每次调用创建文件夹引用，并且事件例程可能调用的宏的参数列表是固定的。

为了测试我计划创建的代码，我首先为自己生成了 790 封电子邮件，这些电子邮件与（我希望）您的相机馈送电子邮件相匹配。我曾计划创建更多，但我认为我的 ISP 已将我归类为垃圾邮件发送者，或者可能是煽动者，它不会让我再发送。这些电子邮件的正文如下所示：

xxx Preamble xxx ‹cr›‹lf›|
Exact Submission Timestamp: 2019-02-22 15:00:00 ‹cr›‹lf›|
xxx Postamble xxx ‹cr›‹lf›|

您的代码需要字符串“Exact Submission Timestamp:”，后跟用作文件名的日期。我假设该日期采用 VBA 可以识别为日期的格式，并且我假设该日期以标准 Windows 换行符（回车、换行）结束。第二个假设很容易改变。我有一个例程可以接受比 VBA 更多的日期格式CDate，如果需要，我可以提供。

每封电子邮件在 2018 年 11 月和 2019 年 2 月之间都有不同的日期和时间。

我永远不会在一个光盘文件夹中保存 8,000 个文件。即使一个文件夹中有几百个文件，也很难找到您想要的文件。我的根文件夹是“C:\DataArea\Test”，但您可以轻松更改它。给定示例电子邮件中的时间戳，我的例程将检查文件夹“C:\DataArea\Test\2019”，然后是“C:\DataArea\Test\2019\02”，最后是“C:\DataArea\Test\2019\02” \22”。如果一个文件夹不存在，它将被创建。然后将附件保存在内部文件夹中。我的代码可以很容易地适应以月级别或小时级别保存文件，具体取决于您每月、每天或每小时获得的这些文件的数量。

我的例行程序会检查收件箱中的每封电子邮件中的字符串“确切提交时间戳：”，后跟日期。如果找到这些，它会检查带有 JPG 扩展名的附件。如果电子邮件通过了所有这些测试，附件将保存在相应的光盘文件夹中，并且电子邮件从 Outlook 文件夹“收件箱”移动到“CameraFeeds1”。移动电子邮件的原因是：(1) 它会清除收件箱；(2) 您可以根据需要随时重新运行例程，而无需找到已处理的电子邮件。我将目标文件夹命名为“CameraFeeds1”，因为您写道您想对这些电子邮件做更多的工作。我认为一旦你完成了这项进一步的工作，你就可以将电子邮件移动到文件夹“CameraFeeds2”。

我假设处理 790 或 8,000 封电子邮件需要很长时间。在我的测试中，持续时间并没有我预期的那么糟糕；790 封电子邮件花了大约一分半钟。但是，我创建了一个用户表单来显示进度。我不能在我的答案中包含该表格，因此您必须创建自己的表格。我的看起来像：

外观并不重要。重要的是窗体的名称和窗体上的四个控件：

表单名称：frmSaveCameraFeeds
文本框名称：txtCountCrnt
文本框名称：txtCountMax
命令按钮名称：cmdStart
命令按钮名称：cmdStop

如果您运行宏StartSaveCameraFeeds，它将加载此表单。单击 [开始] 开始保存过程。您可以让宏一直运行，直到它检查了收件箱中的每封电子邮件，或者您可以随时单击 [停止]。停止按钮并不像我担心的那么重要。我认为例行程序可能需要几个小时，但事实并非如此。

您没有报告 8,000 封电子邮件的位置。我每个帐户都有一个收件箱以及仅用于测试的默认收件箱。我将 790 封测试电子邮件移至默认收件箱并用于GetDefaultFolder引用它。我假设您知道如何在必要时引用另一个文件夹。注意我使用Session而不是名称空间。这两种方法应该是等效的，但我总是使用Session它，因为它更简单，而且我曾经遇到过我无法诊断的名称空间的故障。我引用了相对于收件箱的文件夹“CameraFeeds1”。

您将不得不至少部分调整我的代码。对于最少的更改，请执行以下操作：

创建一个新模块并将此代码复制到其中：

Option Explicit

  Public Const Marker As String = "Exact Submission Timestamp: "
  Public Const RootSave As String = "C:\DataArea\Test"

  Public FldrIn As Outlook.Folder
  Public FldrOut As Outlook.Folder 
Sub StartSaveCameraFeeds()

  ' Reference outlook folders then pass control to frmSaveCameraFeeds

  Set FldrIn = Session.GetDefaultFolder(olFolderInbox)
  Set FldrOut = FldrIn.Parent.Folders("CameraFeeds1")

  Load frmSaveCameraFeeds
  With frmSaveCameraFeeds
    .Caption = "Saving jpg files from Camera feed emails"
    .txtCountCrnt = 0
    .txtCountMax = FldrIn.Items.Count
    .Show vbModal
  End With

  ' Form unloaded by cmdStop within form

  Set FldrIn = Nothing
  Set FldrOut = Nothing

End Sub
Public Sub SaveCameraFeed(ByRef ItemCrnt As MailItem)

  ' Checks a single mail item to be a "camera feed" email.  If the mail item is
  ' a "camera feed" email, it saves the JPG file using the date within the
  ' email body as the file name.  If the mail item is not a "camera feed"
  ' email, it does nothing.

  ' To be a camera feed mail item:
  '  * The text body must contain a string of the form: "xxxyyyy" & vbCr & vbLf
  '    where "xxx" matches the public constant Marker and "yyy" is recognised
  '    by VBA as a date
  '  * It must have an attachment with an extension of "JPG" or "jpg".

  ' If the mail item is a camera feed email:
  '  * In "yyy" any colons are replaced by understores.
  '  * The JPG attachment is saved with the name yyy & ".jpg"

  Dim DateCrnt As Date
  Dim DateStr As String
  Dim DayCrnt As String
  Dim InxA As Long
  Dim MonthCrnt As String
  Dim PathFileName As String
  Dim PosEnd As Long
  Dim PosStart As Long
  Dim SomethingToSave As Boolean
  Dim YearCrnt As String

  SomethingToSave = False   ' Assume no JPG to save until find otherwise
  With ItemCrnt
    PosStart = InStr(1, .Body, Marker)
    If PosStart > 0 Then
      PosStart = PosStart + Len(Marker)
      PosEnd = InStr(PosStart, .Body, vbCr & vbLf)
      DateStr = Mid$(.Body, PosStart, PosEnd - PosStart)
      If IsDate(DateStr) Then
        DateCrnt = DateStr
        For InxA = 1 To .Attachments.Count
          If LCase(Right$(.Attachments(InxA).Filename, 4)) = ".jpg" Then
            SomethingToSave = True
            Exit For
          End If
        Next
      End If
    End If

    If SomethingToSave Then
      DateStr = Replace(DateStr, ":", "_")
      YearCrnt = Year(DateCrnt)
      MonthCrnt = Month(DateCrnt)
      DayCrnt = Day(DateCrnt)
      Call CreateDiscFldrIfItDoesntExist(RootSave, YearCrnt, MonthCrnt, DayCrnt)
      PathFileName = RootSave & "\" & YearCrnt & "\" & MonthCrnt & "\" & DayCrnt & _
                     "\" & Trim(DateStr) & ".jpg"
      .Attachments(InxA).SaveAsFile PathFileName
      .Move FldrOut
    End If

  End With

End Sub
Public Sub CreateDiscFldrIfItDoesntExist(ByVal Root As String, _
                                         ParamArray SubFldrs() As Variant)

  ' If a specified disk folder (not an Outlook folder) does not exist, create it.

  ' Root      A disk folder which must exist and for which the user
  '           must have write permission.
  ' SubFldrs  A list of sub-folders required within folder Root.

  ' Example call: CreateDiscFldrsIfNecessary("C:\DataArea", "Aaa", "Bbb", "Ccc")
  ' Result: Folder "C:\DataArea\Aaa\Bbb\Ccc" will be created if it does not already exist.

  ' Note: MkDir("C:\DataArea\Aaa\Bbb\Ccc") fails unless folder "C:\DataArea\Aaa\Bbb" exists.

  Dim Filename As String
  Dim Fldrname As String
  Dim InxSF As Long

  Fldrname = Root

  For InxSF = LBound(SubFldrs) To UBound(SubFldrs)

    Fldrname = Fldrname & "\" & SubFldrs(InxSF)
    If Not PathExists(Fldrname) Then
      Call MkDir(Fldrname)
    End If

  Next

End Sub     
Public Function PathExists(ByVal Pathname As String) As Boolean

  ' Returns True if path exists

  ' Coded by Tony Dallimore
  ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283

  On Error Resume Next
  PathExists = ((GetAttr(Pathname) And vbDirectory) = vbDirectory)
  On Error GoTo 0

End Function

我必须警告您，我的模块充满了我一直使用的标准例程。我相信我已经包含了我为您编写的代码所使用的所有标准例程。如果代码由于缺少子或函数而失败，请发表评论，我会道歉并将缺少的宏添加到我的代码中。

靠近上述代码顶部的是Public Const RootSave As String = "C:\DataArea\Test". 您必须更改它以引用您的根文件夹。

的第一个说法Sub StartSaveCameraFeeds()是Set FldrIn = Session.GetDefaultFolder(olFolderInbox)。如果电子邮件不在默认收件箱中，请根据需要修改此内容。

在Sub StartSaveCameraFeeds()你的身上会发现PosEnd = InStr(PosStart, .Body, vbCr & vbLf)。如果日期字符串不是由标准 Windows 换行符结束，请根据需要修改此语句。

创建用户表单。添加两个文本框和两个命令按钮。按照上面的定义命名它们。将下面的代码复制到表单的代码区：

Option Explicit
Private Sub cmdStart_Click()

  ' Call SaveCameraFeed for every MailItem in FldrIn

  Dim CountMax As Long
  Dim InxI As Long
  Dim MailItemCrnt As MailItem

  With FldrIn

    CountMax = FldrIn.Items.Count

    For InxI = CountMax To 1 Step -1

      If .Items(InxI).Class = olMail Then
        Set MailItemCrnt = .Items(InxI)
        Call SaveCameraFeed(MailItemCrnt)
        Set MailItemCrnt = Nothing
      End If
      txtCountCrnt = CountMax - InxI + 1
      DoEvents

    Next

  End With

  Unload Me

End Sub
Private Sub cmdStop_Click()

  Unload Me

End Sub

表格代码不需要修改。

正如我已经写过的，这段代码在大约一分半钟内处理了 790 封摄像头的电子邮件。我编写了一个进一步的例程，检查每封电子邮件的日期是否与 jpg 文件的名称匹配。如果您想执行相同的检查，我可以在我的回答中包含此例程。

vba - Saving attachments results in memory errors

问题描述

解决方案

推荐阅读