Inconsistant behavior in forms vba module

[Cyberwolf0000]

Has anyone ever had inconsistant error behavior in a forms vba module. i.e.
I open my form and click a control and I get an Error 3000 (Reserved Error(-
1104), there is not message for this error). I click debug and am able to
step through the code without issue. I am also getting a lot of Cannot open
anymore database errors that I am working on right now. I have found the
offending procedure but have not figured out how to work around it. Here is
the code for the procedure that causes the Cannot open anymore databases. It
breaks on the first set rec and then I can sstep through to the first set rs
and cannot go any further.

Public Sub HourlyGridFill(strDate As Date)

' Error Handler
'On Error GoTo HourlyGridFill_Error

Dim strSQL As String
Dim rec As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim inthr As Integer
Dim bolMatch As Boolean



'Set db = CurrentDb
strSQL = "SELECT C.CompanyName, S.ScheduleDate, S.ScheduleTime, S.TruckWeight,
P.PONumber " & _
"FROM POs AS P INNER JOIN (CompanyInfo AS C INNER JOIN
ScheduleDetails AS S ON C.CompanyID = S.CompanyID) ON P.PONumberID = S.
PONumberID " & _
"WHERE S.ScheduleDate=#" & strDate & "# " & _
"ORDER BY S.ScheduleDate, S.ScheduleTime;"
Debug.Print strSQL & " : " & Now()
Set rs = CurrentDb.OpenRecordset("DayDetail")
With rs
.MoveFirst
For inthr = 0 To 23
Debug.Print inthr & " : " & Now()
Set rec = DBEngine(0)(0).OpenRecordset(strSQL)
rec.MoveFirst
Do Until rec.EOF
.Edit
If Int(Left(rec!ScheduleTime, InStr(1, rec!ScheduleTime, ":",
vbDatabaseCompare) - 1)) = inthr Then
bolMatch = True
!Carrier = rec!CompanyName
!Weight = rec!TruckWeight
!PONumber = rec!PONumber
Else
bolMatch = False
!Carrier = ""
!Weight = Null
!PONumber = Null
End If
.Update
rec.MoveNext
Loop
If rec.EOF And Not rs.EOF Then
rec.MoveFirst

.MoveNext
End If
Next inthr
End With
rec.Close
Set rec = Nothing
rs.Close
Set rs = Nothing

db.Close
Set db = Nothing

On Error GoTo 0
Exit Sub

HourlyGridFill_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure
HourlyGridFill of VBA Document Form_frm_Calendar"
End Sub


Any help or suggestions would be greatly appreciated.

BTW. I am using the Calendar db as the basis for this project and got it
from http://www.weascend.com.

--
James B Gaylord
For the Wolf comes the strength of the Pack,
For the Pack comes the strength of the Wolf,
-R. Kipling
Office 2003 on Win XP SP2

 

[Steve Sanford]

It looks like you are not closing the recordset "rec" before opening it
again. Or the problems could be due to corruption.

You could try the following modified code:



Option Compare Database
Option Explicit

'-----------------------------------------------

Public Sub HourlyGridFill(strDate As Date)

' Error Handler
'On Error GoTo HourlyGridFill_Error

Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim rs As DAO.Recordset

Dim strSQL As String
Dim inthr As Integer
Dim bolMatch As Boolean
Dim msg As String


'Set db = CurrentDb
strSQL = "SELECT C.CompanyName, S.ScheduleDate,"
strSQL = strSQL & " S.ScheduleTime, S.TruckWeight,P.PONumber"
strSQL = strSQL & " FROM POs AS P INNER JOIN (CompanyInfo AS C"
strSQL = strSQL & " INNER JOIN ScheduleDetails AS S"
strSQL = strSQL & " ON C.CompanyID = S.CompanyID)"
strSQL = strSQL & " ON P.PONumberID = S.PONumberID"
strSQL = strSQL & " WHERE S.ScheduleDate=#" & strDate & "#"
strSQL = strSQL & " ORDER BY S.ScheduleDate, S.ScheduleTime;"

'---
Debug.Print strSQL & " : " & Now()
'---

Set rs = CurrentDb.OpenRecordset("DayDetail")
With rs
.MoveFirst
For inthr = 0 To 23
'---
Debug.Print inthr & " : " & Now()
'---
Set rec = db.OpenRecordset(strSQL)
'Set rec = DBEngine(0)(0).OpenRecordset(strSQL)

rec.MoveFirst
Do Until rec.EOF
.Edit
If Int(Left(rec!ScheduleTime, InStr(1, rec!ScheduleTime, ":",
vbDatabaseCompare) - 1)) = inthr Then

bolMatch = True
!Carrier = rec!CompanyName
!Weight = rec!TruckWeight
!PONumber = rec!PONumber
Else
bolMatch = False
!Carrier = ""
!Weight = Null
!PONumber = Null
End If
.Update
rec.MoveNext
Loop

' done with the recordset rec for now
rec.Close


'the lines within the IF statements
' never execute.

'If rec.EOF is TRUE then Not rec.EOF is FALSE
' so
' rec.EOF And Not rs.EOF = FALSE
'
'------------------------------
If rec.EOF And Not rs.EOF Then
rec.MoveFirst

.MoveNext
End If
'------------------------------

Next inthr
End With

On Error Resume Next

rec.Close
Set rec = Nothing

rs.Close
Set rs = Nothing

'you didn't open the database,
'so don't close it
'db.Close

Set db = Nothing

'next line not necessary
'On Error GoTo 0
Exit Sub

HourlyGridFill_Error:
'create message text
msg = "Error " & Err.Number
msg = msg & " (" & Err.Description & ") in"
msg = msg & " procedure HourlyGridFill of"
msg = msg & " VBA Document Form_frm_Calendar"

'display it
MsgBox msg
End Sub
'-----------------------------------------------



HTH

 

[Cyberwolf0000 via AccessMonster.com]

Thanks Steve, I will give it a try.

It looks like you are not closing the recordset "rec" before opening it
again. Or the problems could be due to corruption.

--
James B Gaylord
For the Wolf comes the strength of the Pack,
For the Pack comes the strength of the Wolf,
-R. Kipling
Office 2003 on Win XP SP2