Problem extracting Data from the body of Emails.

  • Thread starter Thread starter Steve Wright
  • Start date Start date
S

Steve Wright

I have the following code to extract information from the body of a number
of Emails.

The problem is that it will only do half of the number of emails stored in
the selected folder at one time. I need to then run the code over the
folder again and again to do all the emails.

Any one know why this might be happening.

TIA
Steve

Option Compare Database

Sub processRAMM()
Dim dbs As Database
Dim appOL As Outlook.Application
Dim oSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oFolder1 As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Dim oBody As String
Dim emailcontents As String
Dim NumberToProcess As Long
Dim RemainingToProcess As Long
Dim NumberProcessed As Long


Dim i As Long
Dim lCountOfFound As Long
On Error Resume Next

'Initialise count of items
lCountOfFound = 0

Set dbs = CurrentDb
Set appOL = CreateObject("Outlook.application")
Set oSpace = appOL.GetNamespace("MAPI")

Set oFolder = oSpace.PickFolder
Set oFolder1 = oSpace.PickFolder
Set oItems = oFolder.Items
oItems.Sort "Received", True

NumberToProcess = oFolder.Items.Count
RemainingToProcess = NumberToProcess
For Each oMail In oItems

If oMail.Subject Like "RAMM Record Carriageway Resurfacing Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T010 Carriageway Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body
RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("surface_date") = ExtractToCR_FX(emailcontents,
"surface_date=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("start_name") = ExtractToCR_FX(emailcontents,
"start_name=")
RAMMRecords("end_name") = ExtractToCR_FX(emailcontents,
"end_name=")
RAMMRecords("startdistance") = ExtractToCR_FX(emailcontents,
"startdistance=")
RAMMRecords("enddistance") = ExtractToCR_FX(emailcontents,
"enddistance=")
RAMMRecords("sealed_area") = ExtractToCR_FX(emailcontents,
"sealed_area=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("surf_offset") = ExtractToCR_FX(emailcontents,
"surf_offset=")
RAMMRecords("surf_width") = ExtractToCR_FX(emailcontents,
"surf_width=")
RAMMRecords("surf_material") = ExtractToCR_FX(emailcontents,
"surf_material=")
RAMMRecords("ovlay_depth") = ExtractToCR_FX(emailcontents,
"ovlay_depth=")
RAMMRecords("chip_size") = ExtractToCR_FX(emailcontents,
"chip_size=")
RAMMRecords("chip_2nd_size") = ExtractToCR_FX(emailcontents,
"chip_2nd_size=")
RAMMRecords("pave_source") = ExtractToCR_FX(emailcontents,
"pave_source=")
RAMMRecords("average_dim1") = ExtractToCR_FX(emailcontents,
"average_dim1=")
RAMMRecords("average_dim2") = ExtractToCR_FX(emailcontents,
"average_dim2=")
RAMMRecords("polished_stone") = ExtractToCR_FX(emailcontents,
"polished_stone=")
RAMMRecords("cutter") = ExtractToCR_FX(emailcontents, "cutter=")
RAMMRecords("cutter_type") = ExtractToCR_FX(emailcontents,
"cutter_type=")
RAMMRecords("surf_binder") = ExtractToCR_FX(emailcontents,
"surf_binder=")
RAMMRecords("adhesion") = ExtractToCR_FX(emailcontents,
"adhesion=")
RAMMRecords("surf_adhesion") = ExtractToCR_FX(emailcontents,
"surf_adhesion=")
RAMMRecords("flux") = ExtractToCR_FX(emailcontents, "flux=")
RAMMRecords("additive") = ExtractToCR_FX(emailcontents,
"additive=")
RAMMRecords("surf_additive") = ExtractToCR_FX(emailcontents,
"surf_additive=")
RAMMRecords("rate") = ExtractToCR_FX(emailcontents, "rate=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
Else
If oMail.Subject Like "RAMM Record Footpath Resurfacing / Kerb and
Channel Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T020 Footpath Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body

RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("completedate") = ExtractToCR_FX(emailcontents,
"completedate=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("side") = ExtractToCR_FX(emailcontents, "side=")
RAMMRecords("startroad") = ExtractToCR_FX(emailcontents,
"startroad=")
RAMMRecords("endroad") = ExtractToCR_FX(emailcontents,
"endroad=")
RAMMRecords("fpstartdistance") = ExtractToCR_FX(emailcontents,
"fpstartdistance=")
RAMMRecords("fpenddistance") = ExtractToCR_FX(emailcontents,
"fpenddistance=")
RAMMRecords("swcstartdistance") = ExtractToCR_FX(emailcontents,
"swcstartdistance=")
RAMMRecords("swcenddistance") = ExtractToCR_FX(emailcontents,
"swcenddistance=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("width") = ExtractToCR_FX(emailcontents, "width=")
RAMMRecords("swclength") = ExtractToCR_FX(emailcontents,
"swclength=")
RAMMRecords("swcsealdistance") = ExtractToCR_FX(emailcontents,
"swcsealdistance=")
RAMMRecords("offset") = ExtractToCR_FX(emailcontents, "offset=")
RAMMRecords("area") = ExtractToCR_FX(emailcontents, "area=")
RAMMRecords("swctype") = ExtractToCR_FX(emailcontents,
"swctype=")
RAMMRecords("extraarea") = ExtractToCR_FX(emailcontents,
"extraarea=")
RAMMRecords("steplength") = ExtractToCR_FX(emailcontents,
"steplength=")
RAMMRecords("position") = ExtractToCR_FX(emailcontents,
"position=")
RAMMRecords("material") = ExtractToCR_FX(emailcontents,
"material=")
RAMMRecords("depth") = ExtractToCR_FX(emailcontents, "depth=")
RAMMRecords("size1") = ExtractToCR_FX(emailcontents, "size1=")
RAMMRecords("bindertype") = ExtractToCR_FX(emailcontents,
"bindertype=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
End If

End If
RemainingToProcess = RemainingToProcess - 1

Next

MsgBox (lCountOfFound & " RAMM Records Processed" & Chr(13) &
RemainingToProcess & " Remaining to Process")


End Sub

Public Function ExtractToCR_FX(textLine As Variant, _
FormItemReq As String) As String
Dim startline As Variant, endline As Variant
Dim extract As Variant

startline = InStr(textLine, FormItemReq)
If startline > 0 Then
startline = startline + Len(FormItemReq)
endline = InStr(startline, textLine, Chr(13))
extracttext = Mid(textLine, startline, _
endline - startline)
End If
If Len(extracttext) = 0 Or Len(extracttext) = Null Then
extracttext = " "
End If
ExtractToCR_FX = extracttext
End Function
 
I notice that the beginning of your code includes Option Compare Database, but it does not
include Option Explicit. I copied your code into a new module, adjusted for all the line
breaks that the news server added and added a reference to the Microsoft Outlook 10.0
Object Library (I'm using Office 2002). Your code compiles okay without Option Explicit,
but it chokes on the first occurrence of the line that reads:

Set RAMMRecords =

with an error that reads: "Compile error: Variable not defined".

When this situation exists, I believe Access will use a variant by default. I believe you
will want to declare RAMMRecords as a DAO recordset, ie.:

Dim RAMMRecords As DAO.Recordset

After fixing this error, we discover a similar compile error on the line that reads:

extracttext =

in the function ExtractToCR_FX. It looks like you declared a variant named "extract", but
you're attempting to use a variable named "extracttext".

I don't know if these fixes will resolve your problem, but I'd start there and see what
happens.

Tom
_______________________________________


I have the following code to extract information from the body of a number
of Emails.

The problem is that it will only do half of the number of emails stored in
the selected folder at one time. I need to then run the code over the
folder again and again to do all the emails.

Any one know why this might be happening.

TIA
Steve

Option Compare Database

Sub processRAMM()
Dim dbs As Database
Dim appOL As Outlook.Application
Dim oSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oFolder1 As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Dim oBody As String
Dim emailcontents As String
Dim NumberToProcess As Long
Dim RemainingToProcess As Long
Dim NumberProcessed As Long


Dim i As Long
Dim lCountOfFound As Long
On Error Resume Next

'Initialise count of items
lCountOfFound = 0

Set dbs = CurrentDb
Set appOL = CreateObject("Outlook.application")
Set oSpace = appOL.GetNamespace("MAPI")

Set oFolder = oSpace.PickFolder
Set oFolder1 = oSpace.PickFolder
Set oItems = oFolder.Items
oItems.Sort "Received", True

NumberToProcess = oFolder.Items.Count
RemainingToProcess = NumberToProcess
For Each oMail In oItems

If oMail.Subject Like "RAMM Record Carriageway Resurfacing Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T010 Carriageway Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body
RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("surface_date") = ExtractToCR_FX(emailcontents,
"surface_date=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("start_name") = ExtractToCR_FX(emailcontents,
"start_name=")
RAMMRecords("end_name") = ExtractToCR_FX(emailcontents,
"end_name=")
RAMMRecords("startdistance") = ExtractToCR_FX(emailcontents,
"startdistance=")
RAMMRecords("enddistance") = ExtractToCR_FX(emailcontents,
"enddistance=")
RAMMRecords("sealed_area") = ExtractToCR_FX(emailcontents,
"sealed_area=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("surf_offset") = ExtractToCR_FX(emailcontents,
"surf_offset=")
RAMMRecords("surf_width") = ExtractToCR_FX(emailcontents,
"surf_width=")
RAMMRecords("surf_material") = ExtractToCR_FX(emailcontents,
"surf_material=")
RAMMRecords("ovlay_depth") = ExtractToCR_FX(emailcontents,
"ovlay_depth=")
RAMMRecords("chip_size") = ExtractToCR_FX(emailcontents,
"chip_size=")
RAMMRecords("chip_2nd_size") = ExtractToCR_FX(emailcontents,
"chip_2nd_size=")
RAMMRecords("pave_source") = ExtractToCR_FX(emailcontents,
"pave_source=")
RAMMRecords("average_dim1") = ExtractToCR_FX(emailcontents,
"average_dim1=")
RAMMRecords("average_dim2") = ExtractToCR_FX(emailcontents,
"average_dim2=")
RAMMRecords("polished_stone") = ExtractToCR_FX(emailcontents,
"polished_stone=")
RAMMRecords("cutter") = ExtractToCR_FX(emailcontents, "cutter=")
RAMMRecords("cutter_type") = ExtractToCR_FX(emailcontents,
"cutter_type=")
RAMMRecords("surf_binder") = ExtractToCR_FX(emailcontents,
"surf_binder=")
RAMMRecords("adhesion") = ExtractToCR_FX(emailcontents,
"adhesion=")
RAMMRecords("surf_adhesion") = ExtractToCR_FX(emailcontents,
"surf_adhesion=")
RAMMRecords("flux") = ExtractToCR_FX(emailcontents, "flux=")
RAMMRecords("additive") = ExtractToCR_FX(emailcontents,
"additive=")
RAMMRecords("surf_additive") = ExtractToCR_FX(emailcontents,
"surf_additive=")
RAMMRecords("rate") = ExtractToCR_FX(emailcontents, "rate=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
Else
If oMail.Subject Like "RAMM Record Footpath Resurfacing / Kerb and
Channel Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T020 Footpath Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body

RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("completedate") = ExtractToCR_FX(emailcontents,
"completedate=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("side") = ExtractToCR_FX(emailcontents, "side=")
RAMMRecords("startroad") = ExtractToCR_FX(emailcontents,
"startroad=")
RAMMRecords("endroad") = ExtractToCR_FX(emailcontents,
"endroad=")
RAMMRecords("fpstartdistance") = ExtractToCR_FX(emailcontents,
"fpstartdistance=")
RAMMRecords("fpenddistance") = ExtractToCR_FX(emailcontents,
"fpenddistance=")
RAMMRecords("swcstartdistance") = ExtractToCR_FX(emailcontents,
"swcstartdistance=")
RAMMRecords("swcenddistance") = ExtractToCR_FX(emailcontents,
"swcenddistance=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("width") = ExtractToCR_FX(emailcontents, "width=")
RAMMRecords("swclength") = ExtractToCR_FX(emailcontents,
"swclength=")
RAMMRecords("swcsealdistance") = ExtractToCR_FX(emailcontents,
"swcsealdistance=")
RAMMRecords("offset") = ExtractToCR_FX(emailcontents, "offset=")
RAMMRecords("area") = ExtractToCR_FX(emailcontents, "area=")
RAMMRecords("swctype") = ExtractToCR_FX(emailcontents,
"swctype=")
RAMMRecords("extraarea") = ExtractToCR_FX(emailcontents,
"extraarea=")
RAMMRecords("steplength") = ExtractToCR_FX(emailcontents,
"steplength=")
RAMMRecords("position") = ExtractToCR_FX(emailcontents,
"position=")
RAMMRecords("material") = ExtractToCR_FX(emailcontents,
"material=")
RAMMRecords("depth") = ExtractToCR_FX(emailcontents, "depth=")
RAMMRecords("size1") = ExtractToCR_FX(emailcontents, "size1=")
RAMMRecords("bindertype") = ExtractToCR_FX(emailcontents,
"bindertype=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
End If

End If
RemainingToProcess = RemainingToProcess - 1

Next

MsgBox (lCountOfFound & " RAMM Records Processed" & Chr(13) &
RemainingToProcess & " Remaining to Process")


End Sub

Public Function ExtractToCR_FX(textLine As Variant, _
FormItemReq As String) As String
Dim startline As Variant, endline As Variant
Dim extract As Variant

startline = InStr(textLine, FormItemReq)
If startline > 0 Then
startline = startline + Len(FormItemReq)
endline = InStr(startline, textLine, Chr(13))
extracttext = Mid(textLine, startline, _
endline - startline)
End If
If Len(extracttext) = 0 Or Len(extracttext) = Null Then
extracttext = " "
End If
ExtractToCR_FX = extracttext
End Function
 
Steve,

I forgot to mention a couple of things in my first reply last night. You might try
changing the line of code that reads:

On Error Resume Next
to:
On Error Goto ProcError

and then include an Errorhandler at the end of your subroutine. It could be that
something is causing the subroutine to fail half way through, but you'd never be informed
about it, since you've instructed it to resume next on error. The function ExtractToCR_FX
should probably also have similar error handling code.

I should have also mentioned that you'll want to make sure to close the DAO recordset, in
order to prevent bloat of your database. So, you might try changing Sub processRAMM() by
adding these lines of code, and removing (or commenting out) the On Error Resume Next at
the location that you had placed it:

Sub processRAMM()
On Error GoTo ProcError


Your code goes here, including adding the statement:
Dim RAMMRecords As DAO.Recordset before attempting to set it to anything.


ExitProc:
On Error Resume Next
RAMMRecords.Close
Exit Sub
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, , _
"Error in processRAMM event procedure..."
Resume ExitProc
End Sub


I include On Error Resume Next as a part of the ExitProc: so that just in case the
recordset RAMMRecords failed to open for any reason, you will not generate an endless loop
of error messages by attempting to close a recordset that is not open. Here is more
information on why you should make sure to close DAO recordsets:

http://support.microsoft.com/default.aspx?scid=kb;en-us;209847

Tom
____________________________________________


I notice that the beginning of your code includes Option Compare Database, but it does not
include Option Explicit. I copied your code into a new module, adjusted for all the line
breaks that the news server added and added a reference to the Microsoft Outlook 10.0
Object Library (I'm using Office 2002). Your code compiles okay without Option Explicit,
but it chokes on the first occurrence of the line that reads:

Set RAMMRecords =

with an error that reads: "Compile error: Variable not defined".

When this situation exists, I believe Access will use a variant by default. I believe you
will want to declare RAMMRecords as a DAO recordset, ie.:

Dim RAMMRecords As DAO.Recordset

After fixing this error, we discover a similar compile error on the line that reads:

extracttext =

in the function ExtractToCR_FX. It looks like you declared a variant named "extract", but
you're attempting to use a variable named "extracttext".

I don't know if these fixes will resolve your problem, but I'd start there and see what
happens.

Tom
_______________________________________


I have the following code to extract information from the body of a number
of Emails.

The problem is that it will only do half of the number of emails stored in
the selected folder at one time. I need to then run the code over the
folder again and again to do all the emails.

Any one know why this might be happening.

TIA
Steve

Option Compare Database

Sub processRAMM()
Dim dbs As Database
Dim appOL As Outlook.Application
Dim oSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oFolder1 As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Dim oBody As String
Dim emailcontents As String
Dim NumberToProcess As Long
Dim RemainingToProcess As Long
Dim NumberProcessed As Long


Dim i As Long
Dim lCountOfFound As Long
On Error Resume Next

'Initialise count of items
lCountOfFound = 0

Set dbs = CurrentDb
Set appOL = CreateObject("Outlook.application")
Set oSpace = appOL.GetNamespace("MAPI")

Set oFolder = oSpace.PickFolder
Set oFolder1 = oSpace.PickFolder
Set oItems = oFolder.Items
oItems.Sort "Received", True

NumberToProcess = oFolder.Items.Count
RemainingToProcess = NumberToProcess
For Each oMail In oItems

If oMail.Subject Like "RAMM Record Carriageway Resurfacing Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T010 Carriageway Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body
RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("surface_date") = ExtractToCR_FX(emailcontents,
"surface_date=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("start_name") = ExtractToCR_FX(emailcontents,
"start_name=")
RAMMRecords("end_name") = ExtractToCR_FX(emailcontents,
"end_name=")
RAMMRecords("startdistance") = ExtractToCR_FX(emailcontents,
"startdistance=")
RAMMRecords("enddistance") = ExtractToCR_FX(emailcontents,
"enddistance=")
RAMMRecords("sealed_area") = ExtractToCR_FX(emailcontents,
"sealed_area=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("surf_offset") = ExtractToCR_FX(emailcontents,
"surf_offset=")
RAMMRecords("surf_width") = ExtractToCR_FX(emailcontents,
"surf_width=")
RAMMRecords("surf_material") = ExtractToCR_FX(emailcontents,
"surf_material=")
RAMMRecords("ovlay_depth") = ExtractToCR_FX(emailcontents,
"ovlay_depth=")
RAMMRecords("chip_size") = ExtractToCR_FX(emailcontents,
"chip_size=")
RAMMRecords("chip_2nd_size") = ExtractToCR_FX(emailcontents,
"chip_2nd_size=")
RAMMRecords("pave_source") = ExtractToCR_FX(emailcontents,
"pave_source=")
RAMMRecords("average_dim1") = ExtractToCR_FX(emailcontents,
"average_dim1=")
RAMMRecords("average_dim2") = ExtractToCR_FX(emailcontents,
"average_dim2=")
RAMMRecords("polished_stone") = ExtractToCR_FX(emailcontents,
"polished_stone=")
RAMMRecords("cutter") = ExtractToCR_FX(emailcontents, "cutter=")
RAMMRecords("cutter_type") = ExtractToCR_FX(emailcontents,
"cutter_type=")
RAMMRecords("surf_binder") = ExtractToCR_FX(emailcontents,
"surf_binder=")
RAMMRecords("adhesion") = ExtractToCR_FX(emailcontents,
"adhesion=")
RAMMRecords("surf_adhesion") = ExtractToCR_FX(emailcontents,
"surf_adhesion=")
RAMMRecords("flux") = ExtractToCR_FX(emailcontents, "flux=")
RAMMRecords("additive") = ExtractToCR_FX(emailcontents,
"additive=")
RAMMRecords("surf_additive") = ExtractToCR_FX(emailcontents,
"surf_additive=")
RAMMRecords("rate") = ExtractToCR_FX(emailcontents, "rate=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
Else
If oMail.Subject Like "RAMM Record Footpath Resurfacing / Kerb and
Channel Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T020 Footpath Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body

RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("completedate") = ExtractToCR_FX(emailcontents,
"completedate=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("side") = ExtractToCR_FX(emailcontents, "side=")
RAMMRecords("startroad") = ExtractToCR_FX(emailcontents,
"startroad=")
RAMMRecords("endroad") = ExtractToCR_FX(emailcontents,
"endroad=")
RAMMRecords("fpstartdistance") = ExtractToCR_FX(emailcontents,
"fpstartdistance=")
RAMMRecords("fpenddistance") = ExtractToCR_FX(emailcontents,
"fpenddistance=")
RAMMRecords("swcstartdistance") = ExtractToCR_FX(emailcontents,
"swcstartdistance=")
RAMMRecords("swcenddistance") = ExtractToCR_FX(emailcontents,
"swcenddistance=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("width") = ExtractToCR_FX(emailcontents, "width=")
RAMMRecords("swclength") = ExtractToCR_FX(emailcontents,
"swclength=")
RAMMRecords("swcsealdistance") = ExtractToCR_FX(emailcontents,
"swcsealdistance=")
RAMMRecords("offset") = ExtractToCR_FX(emailcontents, "offset=")
RAMMRecords("area") = ExtractToCR_FX(emailcontents, "area=")
RAMMRecords("swctype") = ExtractToCR_FX(emailcontents,
"swctype=")
RAMMRecords("extraarea") = ExtractToCR_FX(emailcontents,
"extraarea=")
RAMMRecords("steplength") = ExtractToCR_FX(emailcontents,
"steplength=")
RAMMRecords("position") = ExtractToCR_FX(emailcontents,
"position=")
RAMMRecords("material") = ExtractToCR_FX(emailcontents,
"material=")
RAMMRecords("depth") = ExtractToCR_FX(emailcontents, "depth=")
RAMMRecords("size1") = ExtractToCR_FX(emailcontents, "size1=")
RAMMRecords("bindertype") = ExtractToCR_FX(emailcontents,
"bindertype=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
End If

End If
RemainingToProcess = RemainingToProcess - 1

Next

MsgBox (lCountOfFound & " RAMM Records Processed" & Chr(13) &
RemainingToProcess & " Remaining to Process")


End Sub

Public Function ExtractToCR_FX(textLine As Variant, _
FormItemReq As String) As String
Dim startline As Variant, endline As Variant
Dim extract As Variant

startline = InStr(textLine, FormItemReq)
If startline > 0 Then
startline = startline + Len(FormItemReq)
endline = InStr(startline, textLine, Chr(13))
extracttext = Mid(textLine, startline, _
endline - startline)
End If
If Len(extracttext) = 0 Or Len(extracttext) = Null Then
extracttext = " "
End If
ExtractToCR_FX = extracttext
End Function
 
PS.
Also, try moving the line of code that reads:

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T010 Carriageway Records", DB_OPEN_DYNASET)

above the For....Next loop (For Each oMail In oItems) so that you are only setting this
recordset variable one time, instead of repeatedly setting it for each pass through the
loop.

How many messages was your routine processing successfully? You originally stated "The
problem is that it will only do half of the number of emails stored in the selected folder
at one time." How many messages is this? If you increased or reduced the number of
messages to be processed by 20%, would it still process only half of the remaining
messages, or would it fail at the same message count as it originally fails?

Tom
______________________________________

Steve,

I forgot to mention a couple of things in my first reply last night. You might try
changing the line of code that reads:

On Error Resume Next
to:
On Error Goto ProcError

and then include an Errorhandler at the end of your subroutine. It could be that
something is causing the subroutine to fail half way through, but you'd never be informed
about it, since you've instructed it to resume next on error. The function ExtractToCR_FX
should probably also have similar error handling code.

I should have also mentioned that you'll want to make sure to close the DAO recordset, in
order to prevent bloat of your database. So, you might try changing Sub processRAMM() by
adding these lines of code, and removing (or commenting out) the On Error Resume Next at
the location that you had placed it:

Sub processRAMM()
On Error GoTo ProcError


Your code goes here, including adding the statement:
Dim RAMMRecords As DAO.Recordset before attempting to set it to anything.


ExitProc:
On Error Resume Next
RAMMRecords.Close
Exit Sub
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, , _
"Error in processRAMM event procedure..."
Resume ExitProc
End Sub


I include On Error Resume Next as a part of the ExitProc: so that just in case the
recordset RAMMRecords failed to open for any reason, you will not generate an endless loop
of error messages by attempting to close a recordset that is not open. Here is more
information on why you should make sure to close DAO recordsets:

http://support.microsoft.com/default.aspx?scid=kb;en-us;209847

Tom
____________________________________________


I notice that the beginning of your code includes Option Compare Database, but it does not
include Option Explicit. I copied your code into a new module, adjusted for all the line
breaks that the news server added and added a reference to the Microsoft Outlook 10.0
Object Library (I'm using Office 2002). Your code compiles okay without Option Explicit,
but it chokes on the first occurrence of the line that reads:

Set RAMMRecords =

with an error that reads: "Compile error: Variable not defined".

When this situation exists, I believe Access will use a variant by default. I believe you
will want to declare RAMMRecords as a DAO recordset, ie.:

Dim RAMMRecords As DAO.Recordset

After fixing this error, we discover a similar compile error on the line that reads:

extracttext =

in the function ExtractToCR_FX. It looks like you declared a variant named "extract", but
you're attempting to use a variable named "extracttext".

I don't know if these fixes will resolve your problem, but I'd start there and see what
happens.

Tom
_______________________________________


I have the following code to extract information from the body of a number
of Emails.

The problem is that it will only do half of the number of emails stored in
the selected folder at one time. I need to then run the code over the
folder again and again to do all the emails.

Any one know why this might be happening.

TIA
Steve

Option Compare Database

Sub processRAMM()
Dim dbs As Database
Dim appOL As Outlook.Application
Dim oSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oFolder1 As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Dim oBody As String
Dim emailcontents As String
Dim NumberToProcess As Long
Dim RemainingToProcess As Long
Dim NumberProcessed As Long


Dim i As Long
Dim lCountOfFound As Long
On Error Resume Next

'Initialise count of items
lCountOfFound = 0

Set dbs = CurrentDb
Set appOL = CreateObject("Outlook.application")
Set oSpace = appOL.GetNamespace("MAPI")

Set oFolder = oSpace.PickFolder
Set oFolder1 = oSpace.PickFolder
Set oItems = oFolder.Items
oItems.Sort "Received", True

NumberToProcess = oFolder.Items.Count
RemainingToProcess = NumberToProcess
For Each oMail In oItems

If oMail.Subject Like "RAMM Record Carriageway Resurfacing Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T010 Carriageway Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body
RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("surface_date") = ExtractToCR_FX(emailcontents,
"surface_date=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("start_name") = ExtractToCR_FX(emailcontents,
"start_name=")
RAMMRecords("end_name") = ExtractToCR_FX(emailcontents,
"end_name=")
RAMMRecords("startdistance") = ExtractToCR_FX(emailcontents,
"startdistance=")
RAMMRecords("enddistance") = ExtractToCR_FX(emailcontents,
"enddistance=")
RAMMRecords("sealed_area") = ExtractToCR_FX(emailcontents,
"sealed_area=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("surf_offset") = ExtractToCR_FX(emailcontents,
"surf_offset=")
RAMMRecords("surf_width") = ExtractToCR_FX(emailcontents,
"surf_width=")
RAMMRecords("surf_material") = ExtractToCR_FX(emailcontents,
"surf_material=")
RAMMRecords("ovlay_depth") = ExtractToCR_FX(emailcontents,
"ovlay_depth=")
RAMMRecords("chip_size") = ExtractToCR_FX(emailcontents,
"chip_size=")
RAMMRecords("chip_2nd_size") = ExtractToCR_FX(emailcontents,
"chip_2nd_size=")
RAMMRecords("pave_source") = ExtractToCR_FX(emailcontents,
"pave_source=")
RAMMRecords("average_dim1") = ExtractToCR_FX(emailcontents,
"average_dim1=")
RAMMRecords("average_dim2") = ExtractToCR_FX(emailcontents,
"average_dim2=")
RAMMRecords("polished_stone") = ExtractToCR_FX(emailcontents,
"polished_stone=")
RAMMRecords("cutter") = ExtractToCR_FX(emailcontents, "cutter=")
RAMMRecords("cutter_type") = ExtractToCR_FX(emailcontents,
"cutter_type=")
RAMMRecords("surf_binder") = ExtractToCR_FX(emailcontents,
"surf_binder=")
RAMMRecords("adhesion") = ExtractToCR_FX(emailcontents,
"adhesion=")
RAMMRecords("surf_adhesion") = ExtractToCR_FX(emailcontents,
"surf_adhesion=")
RAMMRecords("flux") = ExtractToCR_FX(emailcontents, "flux=")
RAMMRecords("additive") = ExtractToCR_FX(emailcontents,
"additive=")
RAMMRecords("surf_additive") = ExtractToCR_FX(emailcontents,
"surf_additive=")
RAMMRecords("rate") = ExtractToCR_FX(emailcontents, "rate=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
Else
If oMail.Subject Like "RAMM Record Footpath Resurfacing / Kerb and
Channel Record*" Then

Set RAMMRecords = CurrentDb.OpenRecordset( _
"T020 Footpath Records", DB_OPEN_DYNASET)

RAMMRecords.AddNew
emailcontents = oMail.Body

RAMMRecords("jobno") = ExtractToCR_FX(emailcontents, "jobno=")
RAMMRecords("contract") = ExtractToCR_FX(emailcontents,
"contract=")
RAMMRecords("jobtype") = ExtractToCR_FX(emailcontents,
"jobtype=")
RAMMRecords("completedate") = ExtractToCR_FX(emailcontents,
"completedate=")
RAMMRecords("officer") = ExtractToCR_FX(emailcontents,
"officer=")
RAMMRecords("roadname") = ExtractToCR_FX(emailcontents,
"roadname=")
RAMMRecords("side") = ExtractToCR_FX(emailcontents, "side=")
RAMMRecords("startroad") = ExtractToCR_FX(emailcontents,
"startroad=")
RAMMRecords("endroad") = ExtractToCR_FX(emailcontents,
"endroad=")
RAMMRecords("fpstartdistance") = ExtractToCR_FX(emailcontents,
"fpstartdistance=")
RAMMRecords("fpenddistance") = ExtractToCR_FX(emailcontents,
"fpenddistance=")
RAMMRecords("swcstartdistance") = ExtractToCR_FX(emailcontents,
"swcstartdistance=")
RAMMRecords("swcenddistance") = ExtractToCR_FX(emailcontents,
"swcenddistance=")
RAMMRecords("seallength") = ExtractToCR_FX(emailcontents,
"seallength=")
RAMMRecords("width") = ExtractToCR_FX(emailcontents, "width=")
RAMMRecords("swclength") = ExtractToCR_FX(emailcontents,
"swclength=")
RAMMRecords("swcsealdistance") = ExtractToCR_FX(emailcontents,
"swcsealdistance=")
RAMMRecords("offset") = ExtractToCR_FX(emailcontents, "offset=")
RAMMRecords("area") = ExtractToCR_FX(emailcontents, "area=")
RAMMRecords("swctype") = ExtractToCR_FX(emailcontents,
"swctype=")
RAMMRecords("extraarea") = ExtractToCR_FX(emailcontents,
"extraarea=")
RAMMRecords("steplength") = ExtractToCR_FX(emailcontents,
"steplength=")
RAMMRecords("position") = ExtractToCR_FX(emailcontents,
"position=")
RAMMRecords("material") = ExtractToCR_FX(emailcontents,
"material=")
RAMMRecords("depth") = ExtractToCR_FX(emailcontents, "depth=")
RAMMRecords("size1") = ExtractToCR_FX(emailcontents, "size1=")
RAMMRecords("bindertype") = ExtractToCR_FX(emailcontents,
"bindertype=")
RAMMRecords("notes") = ExtractToCR_FX(emailcontents, "notes=")
RAMMRecords("contractor") = ExtractToCR_FX(emailcontents,
"contractor=")
RAMMRecords("enteredby") = ExtractToCR_FX(emailcontents,
"enteredby=")
RAMMRecords("projectmanager") = ExtractToCR_FX(emailcontents,
"projectmanager=")
RAMMRecords("dateentered") = ExtractToCR_FX(emailcontents,
"dateentered=")
RAMMRecords("comments") = ExtractToCR_FX(emailcontents,
"comments=")
RAMMRecords.Update

oMail.Move oFolder1
lCountOfFound = lCountOfFound + 1
End If

End If
RemainingToProcess = RemainingToProcess - 1

Next

MsgBox (lCountOfFound & " RAMM Records Processed" & Chr(13) &
RemainingToProcess & " Remaining to Process")


End Sub

Public Function ExtractToCR_FX(textLine As Variant, _
FormItemReq As String) As String
Dim startline As Variant, endline As Variant
Dim extract As Variant

startline = InStr(textLine, FormItemReq)
If startline > 0 Then
startline = startline + Len(FormItemReq)
endline = InStr(startline, textLine, Chr(13))
extracttext = Mid(textLine, startline, _
endline - startline)
End If
If Len(extracttext) = 0 Or Len(extracttext) = Null Then
extracttext = " "
End If
ExtractToCR_FX = extracttext
End Function
 
Thanks Tom!

Your suggestions have really helped tidy up the code.

The problem with only doing half of the records at onece still exists.

It seems that it has somthing to do with moving the just processed item to
an other folder as when I comment out the .move instruction it processes all
the records.

Any further Ideas?

Steve
 
Hi Steve,

Once again, I ask how many messages in Outlook are being processed successfully before the
function quits? I'd like to know how many messages, so that I can try simulating the
condition on my PC. Does it always quit on the same number of messages? If you increase
the number of messages to be processed, say by 20%, does it quit at the same number as
before or is it now quitting at half of the remaining messages? Have you tried running
this function with your antivirus software disabled, just to make sure that it is not
implicated in any way?

Does it matter whether the messages to be processed contain the subject:
Like "RAMM Record Carriageway Resurfacing Record*"

versus
Like "RAMM Record Footpath Resurfacing / Kerb and Channel Record*".

In other words, does your function fail with X number of messages with the first subject
string and the same number of messages with the second subject string? I assume you
either deleted or commented out the second occurrence of:

Set RAMMRecords = CurrentDb.OpenRecordset( _
"qryRAMMRecords", DB_OPEN_DYNASET)

so that you are not resetting this variable on every pass through the ELSE IF portion of
your loop. Now that you have removed the "On Error Resume Next" statement, are you
getting any error messages when it quits?


_____________________________________

Thanks Tom!

Your suggestions have really helped tidy up the code.

The problem with only doing half of the records at once still exists.

It seems that it has somthing to do with moving the just processed item to
an other folder as when I comment out the .move instruction it processes all
the records.

Any further Ideas?

Steve
 
Ive now fixed the problem with only half of them being processed. I am now
looping through the items backwards to maintain the correct count in the
collection.

Thanks for all your help Tom it is much appreciated and invaluable.

Steve
 
Back
Top