This might help. I have a product I wrote about 15 years ago that uses a
COM component written in VB6. It's job is basically
to append a record to an Access table and then keep looking for the record
to be marked complete. Since Access is not a good database for web
applications some extra error handling was added. I tested it pretty
heavily to try and break it and it came out pretty well.
Hope it helps,
Mark Andrews
RPT Software
http://www.rptsoftware.com
http://www.donationmanagementsoftware.com
Public Function MakeReport(ByVal QueuePath As Variant, ByVal DatabasePath As
Variant, ByVal Reportname As Variant, ByVal QueryName As Variant, ByVal
QueryText As Variant, ByVal ReportFormat As Variant, Optional ByVal P1 As
Variant = "", Optional ByVal P2 As Variant = "", Optional ByVal P3 As
Variant = "", Optional ByVal P4 As Variant = "", Optional ByVal P5 As
Variant = "", Optional ByVal P6 As Variant = "", Optional ByVal P7 As
Variant = "", Optional ByVal P8 As Variant = "", Optional ByVal P9 As
Variant = "", Optional ByVal P10 As Variant = "") As Variant
'Writes DatabasePath, ReportName, QueryName, QueryText, ReportFormat
'to tblReportQueue table in QueuePath database and
'loops until the report server creates the report and
'updates the record.
'Returns the Report File Name (Report#.pdf or Report#.rtf")
' or
'A description of the error ("Report Error: ...")
Dim rs As ADODB.Recordset
Dim TheReportFile As Variant
Dim Sequence As Long
Dim cn As ADODB.Connection
Dim com As Command
Dim LockCount As Integer
Dim I As Integer
On Error GoTo MakeReport_Error
LockCount = 0
' ** Validation
If (QueuePath = "") Or (DatabasePath = "") Or (Reportname = "") Or
(ReportFormat = "") Then
MakeReport = "Report Error: A parameter was left blank in the ASP
page!"
Exit Function
End If
'Get Sequence Number for Insert
Sequence = GetNextCounter(QueuePath)
If (Sequence = -1) Then
MakeReport = "Report Error: Could not add record to queue due to
problems creating a unique sequence number."
Exit Function
End If
Set com = New Command
Set cn = New ADODB.Connection
'Insert New record
cn.ConnectionString = "DRIVER={Microsoft Access Driver (*.mdb)};" &
"DBQ=" & QueuePath
cn.Open
Set com.ActiveConnection = cn
com.CommandText = "INSERT into tblReportQueue (Sequence, DatabasePath,
ReportName, QueryName, QueryText, ReportFormat, P1, P2, P3, P4, P5, P6, P7,
P8, P9, P10) VALUES (" & Sequence & ", " & FixStr(DatabasePath, ",") &
FixStr(Reportname, ",") & FixStr(QueryName, ",") & FixStr(QueryText, ",") &
FixStr(ReportFormat, ",") & FixStr(P1, ",") & FixStr(P2, ",") & FixStr(P3,
",") & FixStr(P4, ",") & FixStr(P5, ",") & FixStr(P6, ",") & FixStr(P7, ",")
& FixStr(P8, ",") & FixStr(P9, ",") & FixStr(P10, ")")
com.Execute
'Loop until New record is marked Complete
Set rs = New ADODB.Recordset
rs.Open "Select * From tblReportQueue Where Sequence=" & Sequence & "
and Complete=True", cn, 1, 3
Do Until rs.RecordCount > 0
DoEvents
rs.Requery
Loop
'Return name of ReportFile
If (IsNull(rs("ReportFile"))) Then
TheReportFile = "Report Error: " & rs("ErrorMessage")
Else
TheReportFile = rs("ReportFile")
End If
MakeReport_Exit:
rs.Close
cn.Close
MakeReport = TheReportFile
GetObjectContext().SetComplete
Exit Function
MakeReport_Error:
LockCount = LockCount + 1
If LockCount > 5 Then
TheReportFile = "Report Error: Too many simultaneous users. Please
try your report again."
Resume MakeReport_Exit
Else
'Waste time, but let Windows multitask during this dead time
For I = 1 To 1000
DoEvents
Next I
Resume
End If
End Function
Private Function GetNextCounter(ByVal QueuePath As String) As Long
On Error GoTo GetNextCounter_Err
' Returns the next sequence number to be used for insert
' Returns -1 if a valid counter value cannot be retrieved
' due to locking problems.
Dim rs As ADODB.Recordset
Dim NextCounter As Long
Dim LockCount As Integer
Dim I As Integer
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
LockCount = 0
cn.ConnectionString = "DRIVER={Microsoft Access Driver (*.mdb)};" &
"DBQ=" & QueuePath
cn.Open
Set rs = New ADODB.Recordset
rs.Open "tblReportQueue_ID", cn, 1, 3
rs.MoveFirst
NextCounter = rs("NextCounter")
rs("NextCounter") = NextCounter + 1
rs.Update
GetNextCounter = NextCounter
GetNextCounter_Exit:
rs.Close
cn.Close
Exit Function
GetNextCounter_Err:
'Table locked by another user
'Try up to five times before giving up
LockCount = LockCount + 1
If LockCount > 5 Then
GetNextCounter = -1
Resume GetNextCounter_Exit
Else
'Waste time, but let Windows multitask during this dead time
For I = 1 To 1000
DoEvents
Next I
Resume
End If
End Function
