从Outlook获取大量电子邮件到Excel - 内存不足错误

Question

我正在尝试获取我的Outlook帐户中的所有电子邮件及其"正文"元素，并将它们列在Excel工作表中。

有很多电子邮件，因此它会产生内存不足错误。

我相信它的发生是因为"身体"。

我的代码在下面，如果您能告诉我应该做什么，我将不胜感激。

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Operation")
i = 1
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value Then
Range("email_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("email_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_sender").Offset(i, 0).Value = OutlookMail.Sender
Range("email_Body").Offset(i, 0).Value = OutlookMail.Body
Range("email_CC").Offset(i, 0).Value = OutlookMail.CC
Range("email_To").Offset(i, 0).Value = OutlookMail.To
Range("email_ID").Offset(i, 0).Value = OutlookMail.ConversationID
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

Answer 1

遍历文件夹中的所有项目并不是一个好主意和正确的主意：

For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value Then

相反，您需要使用 Outlook 对象模型中 Items 类的Find/FindNext或Restrict方法。它们允许将过滤器应用于Items集合，返回一个新集合，其中包含原始集合中与过滤器匹配的所有项目。

Restrict方法是使用Find方法或FindNext方法循环访问集合中的特定项的替代方法。如果项目数量较少，则Find或FindNext方法比筛选更快。如果集合中有大量项目，则Restrict方法明显更快，尤其是在预计只找到大型集合中的少数项目时。

Public Sub ContactDateCheck()  
Dim myNamespace As Outlook.NameSpace  
Dim myContacts As Outlook.Items  
Dim myItem As Object  
Dim DateStart As Date  
Dim DateToCheck As String  
Dim myRestrictItems As Outlook.Items  
Set myNameSpace = Application.GetNamespace("MAPI")  
Set myContacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items  
DateStart = #01/1/2020#  
DateToCheck = "[LastModificationTime] >= """ & DateStart & """"  
Set myRestrictItems = myContacts.Restrict(DateToCheck)  
For Each myItem In myRestrictItems  
If (myItem.Class = olContact) Then  
MsgBox myItem.FullName & ": " & myItem.LastModificationTime  
End If  
Next  
End Sub

Answer 2

尝试这样的事情：

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim myFolder As MAPIFolder
Dim OutlookMail As Variant
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set myFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Operation")
Dim filterDateStr As String
'format your date string to an acceptable one for the Restrict method
filterDateStr = Format(Range("email_Receipt_Date").Value, "ddddd h:nn AMPM")
Dim myItems As Outlook.Items
'Now return an Items instance that has restricted contents and set to a variable
Set myItems = myFolder.Items.Restrict("[ReceivedTime] > '" & filterDateStr & "'")
Dim i As Long: i = 1
'Loop through the restricted Items!
For Each OutlookMail In myItems
If OutlookMail.Class = olMail Then  'check each item in the Items - is it an email Object?
Range("email_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("email_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_sender").Offset(i, 0).Value = OutlookMail.Sender
Range("email_Body").Offset(i, 0).Value = OutlookMail.Body
Range("email_CC").Offset(i, 0).Value = OutlookMail.CC
Range("email_To").Offset(i, 0).Value = OutlookMail.To
Range("email_ID").Offset(i, 0).Value = OutlookMail.ConversationID
i = i + 1
End If
Next OutlookMail
Set myFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

顺便说一下，您应该限定工作表的范围，以避免在有另一个活动工作表时出现任何意外错误。

Answer 3

根据要求，简要描述我的系统。 如果这还不够详细，请提出问题，我会更新。

这是对我大约 15 年前为自己设计和构建的系统描述。 这可能是我的第一个Outlook宏。 我雇主的技术部门为我们的 Outlook 商店提供了有限的磁盘空间分配。 大多数项目沟通都是通过电子邮件进行的，对于较长的项目，我们在项目结束前就用完了空间。 大多数人打印并删除了他们的电子邮件，但我希望在项目结束之前进行电子访问。

我的解决方案就像你的一样。 我有一个例程，它会运行我的所有文件夹并将每封电子邮件的详细信息输出到 Excel 工作簿。 据我了解，最大的区别是：

• 例程维护工作簿。 对于每封电子邮件，它会检查该电子邮件之前是否已存档。 如果以前没有存档过，则将其存档。 如果它以前被存档并且LastModificationTime没有改变，则什么也没做。 如果之前已存档并且LastModificationTime已更改，则会将以前的记录标记为删除，并创建新的存档。 例程按日期对电子邮件进行排序，因此只有自上次存档以来发送或接收的电子邮件需要检查。 我每天都运行这个例行程序，没花多长时间。
• 我将文本和 Html 正文保存为文件。 我还保存了所有附件。 包含使用HYPERLINK函数的超链接的电子邮件的行。 (这是 Outlook 2003;尽管HYPERLINK完成了我需要的一切，但今天有更强大的技术。 所有这些文件都保存在一个名为"电子邮件"的专用文件夹中。 在这个文件夹中，我每年有一个文件夹，每个月都有一个文件夹。 这限制了每个文件夹的文件数。 文件被命名为 000001.xxx、000002.yyy 等。 我在工作表中维护了每个月下一个可用数字的索引。
• 我保存的属性比您在宏中列出的要多得多。 基本上，我保存了我感兴趣的所有财产。 我的想法是允许我在 Outlook 存储中再次需要电子邮件时"还原"电子邮件，但我从不需要或编码此功能。

使用工作簿作为索引，我可以完全访问我曾经收到或发送的每封电子邮件，即使它们已从我的 Outlook 存储中删除。 我可以按任何属性对电子邮件进行排序，从而轻松找到我想要的任何电子邮件。 我可以单击超链接以查看正文和/或任何附件。 我的很多同事在看到它是多么有用时，要求他们自己的副本或我的宏。 我也有我自己的所有电子邮件存档;我从来没有真正相信过技术部门的档案。

希望这有帮助。 正如我在开始时所说，如果有帮助，请询问更多详细信息。

Answer 4

您可以在索引的 For 循环中释放带有Set outlookMail = Nothing的内存。

Option Explicit
Sub GetFromOutlook()
Dim outlookApp As Outlook.Application
Dim outlookFolder As Outlook.Folder
Dim outlookMail As Outlook.MailItem
Dim i As Long
Set outlookApp = New Outlook.Application
Set outlookFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Operation")
i = 1
Dim outlookFolderItems As Outlook.items
Dim outlookFolderItemsCount As Long
Set outlookFolderItems = outlookFolder.items
outlookFolderItemsCount = outlookFolderItems.Count
Debug.Print "outlookFolderItemsCount: " & outlookFolderItemsCount
' For testing without an Excel workbook
Dim email_Receipt_Date As Date
'email_Receipt_Date = Range("email_Receipt_Date").Value
email_Receipt_Date = Now - 50
Debug.Print "email_Receipt_Date: " & email_Receipt_Date
'The date range is "one-sided" no need to bring in Restrict
'  unless you are determined to do so
' Sort True = newest to oldest
outlookFolderItems.Sort "[ReceivedTime]", True
Dim j As Long
For j = 1 To outlookFolderItemsCount
Debug.Print outlookFolderItems(j).ReceivedTime, outlookFolderItems(j).subject
Next j
'You cannot release memory in a For Each
'For Each OutlookMail In Folder.items
For j = 1 To outlookFolderItemsCount
If TypeName(outlookFolderItems(i)) = "MailItem" Then

Set outlookMail = outlookFolderItems(i)

Debug.Print " i: " & i
Debug.Print "outlookMail.ReceivedTime: " & outlookMail.ReceivedTime

'If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value Then
If outlookMail.ReceivedTime >= email_Receipt_Date Then

Debug.Print " OutlookMail.subject.......: " & outlookMail.subject
'Range("email_subject").Offset(i, 0).Value = OutlookMail.subject

Debug.Print " OutlookMail.ReceivedTime..: " & outlookMail.ReceivedTime
'Range("email_date").Offset(i, 0).Value = OutlookMail.ReceivedTime

Debug.Print " OutlookMail.Sender........: " & outlookMail.Sender
'Range("email_sender").Offset(i, 0).Value = OutlookMail.Sender

Debug.Print " OutlookMail.Body..........: " & outlookMail.Body
'Range("email_Body").Offset(i, 0).Value = OutlookMail.Body

Debug.Print " OutlookMail.CC............: " & outlookMail.CC
'Range("email_CC").Offset(i, 0).Value = OutlookMail.CC

Debug.Print " OutlookMail.To............: " & outlookMail.To
'Range("email_To").Offset(i, 0).Value = OutlookMail.To

Debug.Print " OutlookMail.ConversationID: " & outlookMail.ConversationID
'Range("email_ID").Offset(i, 0).Value = OutlookMail.ConversationID

i = i + 1

Else
' Exit when date not in single-sided range
Debug.Print outlookMail.ReceivedTime & " is outside of single-sided range."
Exit For

End If

End If

Set outlookMail = Nothing   ' <--- Release in an indexed For loop

Next
Debug.Print "Done."
End Sub