I write a VBA project to process the order emails in a folder. However, when running the code, I will always get "Out of Memory" error.
I search online and see many suggests to clear the memory, so I add codes like below:
Set objItem = Nothing
Set objMailItem = Nothing
Redim arrLines(0)
But that seems not working.
Below is the VBA codes:
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 "[email protected]"
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
Below is a sample email to be processed:
********** 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
Update:
The error is caused by the following line:
If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
when strLine contains Japanese characters, as below:
Address2: パティオたまプラーザ308
After searching online, I find similar errors, as below: [VBA][excel] Occurred error When Using 'Japanese - Katakana' in 'inStr'
But the OP said the problem will not reoccur so there are no solutions for the problem.
CodePudding user response：
Apparently memory allocated to objItem in a For Each cannot be freed.
Change to an indexed For Next so there is no 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 "[email protected]"
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
Appears there is something else involved. With your original code using objItem I can generate a file with over 30,000 entries.
Unlikely this will be any better but rather than assigning objMailItem, you could use curFolderItems(i) directly.
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 "[email protected]"
Print #nCSVFileNum, ProcessRegNowOrderEmail(curFolderItems(i))
'End Select
End If
End With
End If
Next
'Next
' Close the file
Close nCSVFileNum
End Sub
CodePudding user response：
It is difficult to see how labels you are not interested in are processed.
This code will process specified labels only.
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
Replace
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
with
Print #nCSVFileNum, ProcessRegNowOrderEmail_Label(objMailItem)