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
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