Outlook VBA“Out of Memory”如何解决？

Question

我编写了一个 VBA 项目来处理文件夹中的订单电子邮件。 但是，在运行代码时，我总是会出现“内存不足”错误。

我在网上搜索，看到很多建议清除memory，所以我添加如下代码：

        Set objItem = Nothing
        Set objMailItem = Nothing
        Redim arrLines(0)

但这似乎不起作用。

以下是 VBA 代码：

Option Explicit

Private Sub btnStart_Click()
  Dim StartDate As Date
  Dim EndDate As Date
  
  StartDate = DateValue("October 1, 2015")
  EndDate = DateValue("January 28, 2023")
  
  Call ProcessOrderEmails(StartDate, EndDate)
End Sub

Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
    Dim objCurFolder As Folder
    Dim objItem As Object
    Dim objMailItem As MailItem
    Dim nCSVFileNum As Integer
      
    '   Create the CSV file
    nCSVFileNum = FreeFile

    If Dir("E:\Temp\OrderStat.csv") <> "" Then
      Kill ("E:\Temp\OrderStat.csv")
    End If
    
    Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
    
    '   Get statistics
    Set objCurFolder = Application.ActiveExplorer.CurrentFolder
    
    For Each objItem In objCurFolder.Items
        If TypeOf objItem Is MailItem Then
            Set objMailItem = objItem
            
            ' Check if the mail is in the date range
            If (objMailItem.SentOn >= StartDate) And (objMailItem.SentOn <= EndDate) Then
              Select Case objMailItem.SenderEmailAddress
                Case "automated@mycommerce.com"
                  Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
              End Select
            End If
        End If
        
        ' Set objItem to nothing to free memory
        Set objItem = Nothing
        Set objMailItem = Nothing
    Next
    
    '   Close the file
    Close nCSVFileNum
End Sub

Private Function ReplaceNewLine(strText As String, strNewLine As String) As String
  ReplaceNewLine = Replace(strText, vbCrLf, strNewLine)
  ReplaceNewLine = Replace(ReplaceNewLine, vbCr, strNewLine)
  ReplaceNewLine = Replace(ReplaceNewLine, vbLf, strNewLine)
End Function

Private Function SplitLines(strText As String) As Variant
  SplitLines = Split(ReplaceNewLine(strText, vbNewLine), vbNewLine)
End Function

' strEntryName should include :, like this RegNow OrderItemID:
Private Function GetEntryValue(strEntryLine As String, strEntryName As String, ByRef strEntryValue) As Boolean
  Dim strLine As String
  
  ' Initialize result to False by default
  GetEntryValue = False
  
  ' Parse the line
  strLine = ReplaceNewLine(Trim(strEntryLine), "")
  
  If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
    strEntryValue = Trim(Replace(strLine, strEntryName, "", 1, -1, vbTextCompare))
    GetEntryValue = True
  End If
End Function

Private Function ProcessRegNowOrderEmail(objMailItem As MailItem) As String
  Dim arrLines() As String
  Dim strLine As String
  Dim strOrderID As String
  Dim strProduct As String
  Dim strProfit As String
  Dim I As Integer

  arrLines = SplitLines(objMailItem.Body)
  
  For I = LBound(arrLines, 1) To UBound(arrLines, 1)
    Call GetEntryValue(arrLines(I), "RegNow OrderItemID:", strOrderID)
    Call GetEntryValue(arrLines(I), "Product Name:", strProduct)
    Call GetEntryValue(arrLines(I), "Profit:", strProfit)
  Next I
  
  ProcessRegNowOrderEmail = "RegNow," & strOrderID & "," & strProduct & "," & strProfit
  
  ReDim arrLines(0)
End Function

下面是一个待处理的样本email：

********** DO NOT REPLY TO THIS EMAIL **********

*** Transaction Identification ***
Date:               2017-03-14 02:14:14 (Pacific Standard Time) 
RegNow OrderID:     XXXXXX-XXXXX
RegNow OrderItemID: XXXXXX-XXXXX

*** Gift Information ***
Gift:               no
Pickup:             no

*** Product Information ***
Item #:             #####-#
Product Name:       My Product
Quantity:           1
Tax:                0.00 USD
Total:              199.95 USD
Profit:             189.15

更新：

该错误是由以下行引起的：

If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then

当 strLine 包含日文字符时，如下：

Address2: パティオたまプラーザ308

网上搜索后，发现类似的错误，如下： [VBA][excel] Occurred error When Using 'Japanese - Katakana' in 'inStr'

https://social.msdn.microsoft.com/Forums/en-US/06df9b54-ad75-4c18-9577-84e52b6e03a1/how-can-i-use-the-japanese-for-instr-vba-?forum=exceldev

但 OP 表示该问题不会再次发生，因此没有解决该问题的方法。

Answer 1

显然无法释放分配给For Each中的objItem的 memory。

更改为索引For Next因此没有objItem 。

Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)

    Dim objCurFolder As Folder
    Dim objMailItem As MailItem
    Dim nCSVFileNum As Integer
      
    '   Create the CSV file
    nCSVFileNum = FreeFile

    If dir("E:\Temp\OrderStat.csv") <> "" Then
      Kill ("E:\Temp\OrderStat.csv")
    End If
    
    Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
    
    '   Get statistics
    Set objCurFolder = Application.ActiveExplorer.currentFolder
    
    Dim curFolderItems As Items
    Set curFolderItems = objCurFolder.Items
    
    Dim curFolderItemsCount As Long
    curFolderItemsCount = curFolderItems.count
    
    Dim i As Long
    
    For i = 1 To curFolderItemsCount
    
        If TypeOf curFolderItems(i) Is MailItem Then
        
            Set objMailItem = curFolderItems(i)
            
            With objMailItem
                
                ' Check if the mail is in the date range
                If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
                    
                    Select Case .senderEmailAddress
                        Case "automated@mycommerce.com"
                            Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
                        
                    End Select
                End If
            
            End With
            
            ' free memory
            Set objMailItem = Nothing
            
        End If
        
    Next
    
    '   Close the file
    Close nCSVFileNum
End Sub

似乎还有其他事情涉及。 使用您使用objItem的原始代码，我可以生成一个包含超过 30,000 个条目的文件。

这不太可能会更好，但您可以直接使用curFolderItems(i)而不是分配objMailItem 。

Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)

    Dim objCurFolder As Folder
    Dim nCSVFileNum As Integer
    
    Dim pathFile As String
    pathFile = "E:\Temp\OrderStat.csv"
        
    '   Create the CSV file
    nCSVFileNum = FreeFile
    Debug.Print nCSVFileNum
    
    If dir(pathFile) <> "" Then
        Kill pathFile
    End If
    
    Open pathFile For Output Lock Write As #nCSVFileNum
            
    '   Get statistics
    Set objCurFolder = Application.ActiveExplorer.currentFolder
    
    Dim curFolderItems As Items
    Set curFolderItems = objCurFolder.Items
    
    Dim curFolderItemsCount As Long
    curFolderItemsCount = curFolderItems.count
            
    Dim i As Long
    
    Dim j As Long
    
    ' for testing the limit
    'For j = 1 To Int(1000 / curFolderItemsCount) + 1
    
        For i = 1 To curFolderItemsCount
        
            If TypeOf curFolderItems(i) Is MailItem Then
            
                Dim n As Long
                n = n + 1
                Debug.Print n
                
                With curFolderItems(i)
                    
                    ' Check if the mail is in the date range
                    If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
                        
                        'Select Case .senderEmailAddress
                            'Case "automated@mycommerce.com"
                                Print #nCSVFileNum, ProcessRegNowOrderEmail(curFolderItems(i))
                          
                        'End Select
                    End If
                    
                End With
            End If
            
        Next
        
    'Next
    
    '   Close the file
    Close nCSVFileNum
End Sub

Answer 2

很难看出你不感兴趣的标签是如何处理的。

此代码将仅处理指定的标签。

Option Explicit

Function ParseTextLinePair(strSource As String, strLabel As String)

    ' https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2007/dd492012(v=office.12)

    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
    
    If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, intLocLabel, intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    
    ParseTextLinePair = Trim(strText)
    
End Function

Private Function ProcessRegNowOrderEmail_Label(objMailItem As MailItem) As String
    
    Dim strOrderID As String
    Dim strProduct As String
    Dim strProfit As String
    
    strOrderID = ParseTextLinePair(objMailItem.body, "RegNow OrderItemID:")
    strProduct = ParseTextLinePair(objMailItem.body, "Product Name:")
    strProfit = ParseTextLinePair(objMailItem.body, "Profit:")

    ProcessRegNowOrderEmail_Label = "RegNow," & strOrderID & "," & strProduct & "," & strProfit

End Function

代替

Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)

和

Print #nCSVFileNum, ProcessRegNowOrderEmail_Label(objMailItem)

Answer 3

经过多次测试，我发现

对于 TextBox1.Text 中的日语字符，使用 vbTextCompare 调用 InStr 将导致“内存不足”：

nPos = InStr(1, TextBox1.Text, "Address2", vbTextCompare)

但是使用 vbBinaryCompare，一切都很好：

nPos = InStr(TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2", vbBinaryCompare)

感谢您的大力帮助！