Questions

Multiple recordsets in Access 2003 vba

+
0 Votes
Locked

Multiple recordsets in Access 2003 vba

Donald_SUTTON
I have an unbound form which is to display a comparison of up to 4 sets of data according to user choice on a preceding form. The first form works OK and creates up to 4 queries. I then open the second form and populate Labels with the data since the client wants a side by side comparison and not horizontal spreadsheet like comparison which would be easy. I can get the first recordset to display. The code reads in the fields of the recordset and compares the value of the field against the fieldname in the caption property of the labels. The respective labels have the caption replaced with the field value. I do this because the order in which the fields are to be displayed is determined and not the table or query order. It works for the first recordset but I am having dificulty in getting the code to change the recordset. I have tried lots of solutions. Code listing of second form below SQL10,SQL20 etc are the user selected queries created in the previous form.

Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Error


Stage = 300: ErrorTxt(Stage) = " setting current database (dB)"
Set dB = CurrentDb
For ItemCount = 1 To n
Select Case ItemCount 'Contains number of vehicles selected
Case Is = 1
Set MyRecSet = dB.OpenRecordset(SQL10, dbOpenSnapshot, dbReadOnly) 'original test OK
'RecSet1.Requery
Flag2 = True 'set to True to test
'Flag2 = False 'Don't show field list
Stage = 310: ErrorTxt(Stage) = "calling function to get field names"
'Returns field names in array FieldHandle(n), FldNum = number of fields
'Call GetFieldNames function - pass MyRecSet and Flag2 - Do once
'MyRecSet = OpenRecordset - Flag2 True = Show Field List/False = Don't Show Field list
'Check for an empty recordset
If Not (MyRecSet.BOF And MyRecSet.EOF) Then
Stage = 35: ErrorTxt(Stage) = "populating recordset moving last record" & vbCrLf
MyRecSet.MoveLast
Stage = 36: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & " moving to last record." & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Recordset Name = " & MyRecSet.Name
RecCount = MyRecSet.RecordCount
Stage = 37: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & "Setting record count then moving to first record."
MyRecSet.MoveFirst
Else
Msg = "Vehicle choice " & LoopIt & " has empty recordset"
Title = "Empty Recordset Error"
MsgBox Msg, vbCritical, Title
GoTo Form_Open_Exit
End If
Stage = 38: ErrorTxt(Stage) = "calling GetFieldNames function"
'MyRecSet = dB.OpenRecordset(SQL10, dbOpenSnapshot)
Call GetFieldNames
With MyRecSet
For Z = 1 To 23 'Inner Loop
ControlHandle = "Col" & ItemCount & "Row" & Z 'Set name of control
'Should only happen when itemcount = 1 as field names are the same for each recordset
CrtlArray(Z, 0) = ControlHandle
CrtlArray(Z, 1) = Me.Controls(ControlHandle).Caption
'Debugging
Msg = Msg & "Control = " & ControlHandle & " Caption = " & CrtlArray(Z, 1)
'FieldName = FieldHandle(Z) 'Get the field name then get the value from the recordset
Stage = 311: ErrorTxt(Stage) = "getting value from field in recordset" & vbCrLf
If Not IsNull(MyRecSet.Fields(CrtlArray(Z, 1)).Value) Then
Fetch = .Fields(CrtlArray(Z, 1)).Value 'get value
Stage = 312: ErrorTxt(Stage) = "applying values to labels on form" & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Value being applied = " & Fetch & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Inner loop = " & Z & " Outer loop = " & LoopIt
Me.Controls(ControlHandle).Caption = Fetch 'Apply value to control
Else
Stage = 313: ErrorTxt(Stage) = "null value found and applying hash value"
Me.Controls(ControlHandle).Caption = "#####" 'Apply value to control
End If
Next Z 'Inner Loop
End With
Case Is = 2
Stage = 320: ErrorTxt(Stage) = "assign next recordset"
Set RecSet2 = dB.OpenRecordset(SQL20, dbOpenSnapshot, dbReadOnly) 'original test OK
Stage = 321
'Set MyRecSet = RecSet2.NextRecordset
Set MyRecSet = RecSet2 'alternative
With MyRecSet
'Check for empty recordset then populate
If Not (MyRecSet.BOF And MyRecSet.EOF) Then
Stage = 35: ErrorTxt(Stage) = "populating recordset moving last record" & vbCrLf
.MoveLast
Stage = 36: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & " moving to last record." & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Recordset Name = " & .Name
RecCount = MyRecSet.RecordCount
Stage = 37: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & "Setting record count then moving to first record."
.MoveFirst
Else
Msg = "Vehicle choice " & ItemCount & " has empty recordset"
Title = "Empty Recordset Error"
MsgBox Msg, vbCritical, Title
GoTo Form_Open_Exit
End If
For Z = 1 To 23 'Inner Loop
ControlHandle = "Col" & ItemCount & "Row" & Z 'Set name of control

'Debugging
Msg = Msg & "Control = " & ControlHandle & " Caption = " & CrtlArray(Z, 1)
'FieldName = FieldHandle(Z) 'Get the field name then get the value from the recordset
Stage = 326: ErrorTxt(Stage) = "getting value from field in recordset" & vbCrLf
If Not (.Fields(CrtlArray(Z, 1)).Value) = "" Then
Fetch = .Fields(CrtlArray(Z, 1)).Value 'get value
Stage = 327: ErrorTxt(Stage) = "applying values to labels on form" & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Value being applied = " & Fetch & vbCrLf
ErrorTxt(Stage) = ErrorTxt(Stage) & "Inner loop = " & Z & " Outer loop = " & LoopIt
Me.Controls(ControlHandle).Caption = Fetch 'Apply value to control
Else
Stage = 328: ErrorTxt(Stage) = "null value found and applying hash value"
Me.Controls(ControlHandle).Caption = "#####" 'Apply value to control
End If
Next Z 'Inner Loop
End With
Case Is = 3
Set RecSet3 = dB.OpenRecordset(SQL30, dbOpenSnapshot, dbReadOnly) 'original test OK
Case Is = 4
Set RecSet4 = dB.OpenRecordset(SQL40, dbOpenSnapshot, dbReadOnly) 'original test OK
End Select
Next ItemCount




'Check for an empty recordset
'If Not (.BOF And .EOF) Then
'Stage = 35: ErrorTxt(Stage) = "populating recordset moving last record" & vbCrLf
'.MoveLast
'Stage = 36: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & " moving to last record." & vbCrLf
'ErrorTxt(Stage) = ErrorTxt(Stage) & "Recordset Name = " & .Name
'RecCount = .RecordCount
'Stage = 37: ErrorTxt(Stage) = ErrorTxt(Stage - 1) & "Setting record count then moving to first record."
'.MoveFirst
'Else
'Msg = "Vehicle choice " & LoopIt & " has empty recordset"
'Title = "Empty Recordset Error"
'MsgBox Msg, vbCritical, Title
'GoTo Form_Open_Exit
'End If

'Stage = 40: ErrorTxt(Stage) = "looping through field names" & vbCrLf
'Msg = "Stored Label names and captions" & vbCrLf
'For Z = 1 To 23 'Inner Loop
'ControlHandle = "Col" & LoopIt & "Row" & Z 'Set name of control
'If LoopIt = 1 Then
'Should only happen when itemcount = 1 as field names are the same for each recordset
'CrtlArray(Z, 0) = ControlHandle
'CrtlArray(Z, 1) = Me.Controls(ControlHandle).Caption
'End If
'Debugging
'Msg = Msg & "Control = " & ControlHandle & " Caption = " & CrtlArray(Z, 1)
'FieldName = FieldHandle(Z) 'Get the field name then get the value from the recordset
' Stage = 41: ErrorTxt(Stage) = "getting value from field in recordset" & vbCrLf
'If Not .Fields(CrtlArray(Z, 1)).Value = "" Then
'Fetch = .Fields(CrtlArray(Z, 1)).Value 'get value
'Stage = 45: ErrorTxt(Stage) = "applying values to labels on form" & vbCrLf
'ErrorTxt(Stage) = ErrorTxt(Stage) & "Value being applied = " & Fetch & vbCrLf
'ErrorTxt(Stage) = ErrorTxt(Stage) & "Inner loop = " & Z & " Outer loop = " & LoopIt
'Me.Controls(ControlHandle).Caption = Fetch 'Apply value to control
'Else
'Stage = 47: ErrorTxt(Stage) = "null value found and applying hash value"
'Me.Controls(ControlHandle).Caption = "#####" 'Apply value to control
'End If
'Next Z 'Inner Loop

MsgBox Msg, vbOKOnly, "Test of Control Array"



Form_Open_Exit:

Stage = 50: ErrorTxt(Stage) = "tidying up"
Set MyRecSet = Nothing
Set RecSet1 = Nothing
Set RecSet2 = Nothing
Set RecSet3 = Nothing
Set RecSet4 = Nothing
Set dB = Nothing
Exit Sub

Form_Open_Error:

Msg = "Error No " & Err.Number & vbCrLf
Msg = Msg & "Description:" & vbCrLf
Msg = Msg & Err.Description & vbCrLf
Msg = Msg & "Error occured at Stage " & Stage & " while" & vbCrLf
Msg = Msg & ErrorTxt(Stage)
Title = "Error Assigning Query Values to Textboxes"
MsgBox Msg, vbCritical, Title
If Err.Number = 13 Then
Resume Next
Else
Resume Form_Open_Exit
End If

End Sub