How to Solve "Out of Memory" when applying InStr to Japanese characters?

Question

When I process emails in a folder I get "Out of Memory" error.

Searching online I see many suggests to clear the memory, so I added code like below:

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

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

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

---

The error is caused by the following line:

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

when strLine contains Japanese characters:

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

Searching online, I find similar posts: [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

Answer 1

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)