Scanning Through "Memo" Field Is Very Slow

[Rich Locus]

Hello Access Group:

I'm trying to find a faster way to eliminate non-printable characters from a
memo field. I have an Access application that reads email from Outlook and
for certain messages saves the text of the message into a table in a Memo
field. The issue is that so many emails have embedded characters that if
copied straight to the memo field show up as black rectangles
(non-printable). It's not pretty sight when trying to read through the
jumble of black boxes.

So I was able to write a routine that loops through every character of the
email text and eliminates the non-printables by copying only valid characters
(character-by-character) to a variant data type, then when finished, copying
the variant to the table's memo field.

Here's a snippet of code

' ************************************************************
' Microsoft Access Code After Reading an Outlook Email Message
' ************************************************************
Dim varCleanBody As Variant
Dim i As Long
Dim intConvertedToOctal As Integer
' Note - EmailText is Defined As a Memo Field in a Table

' ****************************************************
' Scan Through Each Character Of An Email Message
' And Eliminate Non-Printing Characters
' (Keep CR/LF which is Octal 12 and 15)
' By Only Moving Printable Characters To varCleanBody
' Then moves the filtered results from varCleanBody
' to Table Field "EmailText" Which is Defined as Memo
' ****************************************************
varCleanBody = ""
For i = 1 To Len(Mailobject.Body)
intConvertedToOctal = Oct(Asc(Mid(Mailobject.Body, i, 1)))
If (intConvertedToOctal = 12 Or intConvertedToOctal = 15 Or _
intConvertedToOctal > 37) Then
varCleanBody = varCleanBody & Mid(Mailobject.Body, i, 1)
End If
Next i
recOut!EmailText = varCleanBody

This code works but it takes an extremely long time to run.

 

[Allen Browne]

Suggestions to make that code more efficient:
1. Operate on strings rather than variants.
2. Reduce the number of function calls.
3. Use Select Case as a way of defining the acceptable characters.
4. Declare your data types to match the functions you are calling (Longs
rather than integers here.)

Function PrintableOnly(ByVal strIn As String) As String
Dim i As Long
Dim strOut As String
Dim strChar As String

For i = 1& To Len(strIn)
strChar = Mid(strIn, i, 1&)
Select Case Asc(strChar)
Case 10, 13, Is >= 32
strOut = strOut & strChar
End Select
Next
PrintableOnly = strOut
End Function

 

[david]

And, now that it's cleaned up, you probably want to
include 9 as well as 10 and 13:

Case 9, 10, 13, Is >= 32

9 is the tab character, and it is printable.

(david)

Suggestions to make that code more efficient:
1. Operate on strings rather than variants.
2. Reduce the number of function calls.
3. Use Select Case as a way of defining the acceptable characters.
4. Declare your data types to match the functions you are calling (Longs
rather than integers here.)

Function PrintableOnly(ByVal strIn As String) As String
Dim i As Long
Dim strOut As String
Dim strChar As String

For i = 1& To Len(strIn)
strChar = Mid(strIn, i, 1&)
Select Case Asc(strChar)
Case 10, 13, Is >= 32
strOut = strOut & strChar
End Select
Next
PrintableOnly = strOut
End Function

 

[vanderghast]

I would give a try to a double index run, in order to create a lot of
strings (trough concatenation in a loop).


Function PrintableOnly(ByVal strIn As String) As String
Dim i As Long ' where I am to read
Dim j as Long ' where I am to write
' Dim strOut As String
Dim strChar As String

j = 0 ' intialize explicitly (not required but for completeness)

For i = 1& To Len(strIn)
strChar = Mid$(strIn, i, 1&)

Select Case Asc(strChar)
Case 9, 10, 13, Is >= 32

j=j+1
Mid$(strIn, j, 1) = strChar

End Select

Next

PrintableOnly = Left$(strIn, j ) ' shorter string, now

End Function



The advantage is that is uses only one string, ever (Concatenation trough a
loop may end up by exceeding the reserved space, buffer, and force another
string creation). Note that when the character is not printable, j is not
increased, so the next position to be filled, j+1, is still 'free' to accept
the next printable character (or CR, LF), which makes the algorithm like
sliding one character at a time, into proper place. I also use the $ string
function to avoid possible VBA automatic casting to 'variant'.


The ByVal is important, in the argument, else, the original string would
have been modified, but if the original string does not matter, you may save
few micro seconds by using ByRef instead (and while you are at it, change
the Function to a Sub, since the result will be the 'initial variable' which
would have been modified... but those micro optimizations are probably
without human perceptible effect as runtime execution is concerned, and too
error prone if used in another context, without remembering all the involved
details).




Vanderghast, Access MVP

And, now that it's cleaned up, you probably want to
include 9 as well as 10 and 13:

Case 9, 10, 13, Is >= 32

9 is the tab character, and it is printable.

(david)

 

[Rich Locus]

To All of you that helped, THANKS! These are good suggestions and I'm going
to run with them.

 

[Rich Locus]

Thanks again:
For All of you that helped me redesign the non-printable character stripper,
the time for a typical run went from 10 minutes down to 2 seconds... amazing.

Here's the final code with your suggestions. It reads all mail in the
Outlook Inbox, and for those items with a subject line of "Client" adds the
mail to a database table after it has cleaned the non-printables in the
message body. It moves the mail from the inbox to one of two other
historical folders.

Option Compare Database
Option Explicit

Public Function ReadInboxAndMoveWithCharReplaceV3()
Dim TempRst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim SavedMailFolder As Outlook.MAPIFolder
Dim RejectMailFolder As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim SavedMailItems As Outlook.MailItem
Dim RejectMailItems As Outlook.MailItem
Dim Mailobject As Object
Dim db As DAO.Database
Dim i As Long

'DoCmd.SetWarnings False
'DoCmd.RunSQL "Delete * from tbl_outlooktemp"
'DoCmd.SetWarnings True

Set db = CurrentDb

Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set SavedMailFolder =
OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Parent.Folders("Saved Mail")
Set RejectMailFolder =
OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Parent.Folders("Rejects")
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
'

Set InboxItems = Inbox.Items

dteUpdateTime = Date + Time
intUpdateCount = 0

For i = InboxItems.Count To 1 Step -1
Set Mailobject = InboxItems(i)

If UCase(Left(Mailobject.Subject, 6)) <> "CLIENT" Then
Mailobject.UnRead = False
Set SavedMailItems = Mailobject.Move(RejectMailFolder)
intUpdateCount = intUpdateCount + 1
Else
With TempRst
.AddNew
!Subject = Mailobject.Subject
!from = Mailobject.SenderName
!To = Mailobject.To
!Body = PrintableOnly(Mailobject.Body)
!DateSent = Mailobject.SentOn
.Update
Mailobject.UnRead = False
Set SavedMailItems = Mailobject.Move(SavedMailFolder)
intUpdateCount = intUpdateCount + 1
End With
End If
Next

Set TempRst = Nothing
Set OlApp = Nothing
Set Inbox = Nothing
Set SavedMailFolder = Nothing
Set InboxItems = Nothing
Set SavedMailItems = Nothing
Set Mailobject = Nothing

End Function

Function PrintableOnly(ByVal strIn As String) As String
Dim i As Long ' where I am to read
Dim j As Long ' where I am to write

Dim strChar As String

j = 0 ' intialize explicitly (not required but for completeness)

For i = 1& To Len(strIn)
strChar = Mid$(strIn, i, 1&)
Select Case Asc(strChar)
Case 10, 13, Is >= 32
j = j + 1
Mid$(strIn, j, 1) = strChar
End Select
Next

PrintableOnly = Left$(strIn, j) ' shorter string, now

End Function