Dear Forum,
I have a problem with connecting a database with more then one table to a VB-Form (please find the attached code for detailed information).
The tables in the database are connected by using id`s. So when moving a recordset of the main entry forward, all records in the tables which are bounded to a control should move forward.
The main problem is, that I have tables I like to display in the GUI with datacombos, with checkboxes, with option buttons, with textfields and last but not least OLE controls for displaying MS Formula Manager 3.0 objects stored in the database.
The difficulty is, that I want not use the ADO control, so that I have to programm the steering process manually.
MANY THANKS for HELP
Form
_________________________________________________________________________
Public eventhandler As dBEvent
Private bindCol As BindingCollection
_________________________________________________________________________
Private Sub Form_Load()
Set eventhandler = New dBEvent 'eventhandler=classmodule
Set bindCol = New BindingCollection
'binding the textboxes in the main table STRUCTURAL_INDICATOR (rstStructuralIndicator) -- THIS WORKS FINE
With bindCol
Set .DataSource = eventhandler.rstStructuralIndicator
.Add txtStrucShortName(0), "Text", "struc_short_name"
.Add txtStrucShortName(1), "Text", "struc_short_name"
.Add txtStrucShortName(2), "Text", "struc_short_name"
.Add txtStrucShortName(3), "Text", "struc_short_name"
.Add txtStrucShortName(4), "Text", "struc_short_name"
.Add txtStrucShortName(5), "Text", "struc_short_name"
.Add txtStrucShortName(6), "Text", "struc_short_name"
.Add txtStrucShortName(7), "Text", "struc_short_name"
.Add txtStrucFullName(0), "Text", "struc_full_name"
.Add txtStrucFullName(1), "Text", "struc_full_name"
.Add txtStrucFullName(2), "Text", "struc_full_name"
.Add txtStrucFullName(3), "Text", "struc_full_name"
.Add txtStrucFullName(4), "Text", "struc_full_name"
.Add txtStrucFullName(5), "Text", "struc_full_name"
.Add txtStrucFullName(6), "Text", "struc_full_name"
.Add txtStrucFullName(7), "Text", "struc_full_name"
End With
'binding the dataCombo in the table INDICATOR_CATEGORY (rstIndicatorCategory) -- THIS WORKS ALSO FINE
With dbcCategory
Set .DataSource = eventhandler
.DataMember = "STRUCTURAL_INDICATOR
.DataField = "struc_indicator_id"
.RowMember = "INDICATOR_CATEGORY"
Set .RowSource = eventhandler
.BoundColumn = "struc_category_id"
.ListField = "category"
End With
'How to bind further textboxes with attributes in other tables (maybe like TABLE_XY) (rstXY) within the same database in relation to rstStructuralIndicator
???? (HERE I HAVE A PROBLEM)
'How to connect a checkbox getting the yes/no values from another table, and optionbuttons?
???? (HERE I HAVE A PROBLEM)
'How to establish a connection to a table with OLE Objects in it
???? (HERE I HAVE A PROBLEM)
Exit_:
Screen.MousePointer = vbNormal
On Error Resume Next
Exit Sub
ErrHandler:
Screen.MousePointer = vbNormal
MsgBox "Unerwarteter Fehler " & (Err.Number And &HFFFF&) & " in Prozedur 'Form_Load': " & Err.Description, vbCritical
Resume Exit_
End Sub
_________________________________________________________________________
dBEvent.cls
_________________________________________________________________________
Option Explicit
'Middle-Tier
'Datenquelle liefert mehrere Datenelemente
_________________________________________________________________________
Public WithEvents rstStructuralIndicator As Recordset
Public rstAuthor As Recordset
Public rstBasedOn As Recordset
Public rstBioregion As Recordset
Public rstCharacterization As Recordset
Public rstFormula As Recordset
Public rstFormulaDescription As Recordset
Public rstFormulaParameter As Recordset
Public rstFormulaRange As Recordset
Public rstHelpTable1 As Recordset
Public rstIndicatorGroup As Recordset
Public rstIndicatorCategory As Recordset
Public rstInstitution As Recordset
Public rstInstitutionTestsite As Recordset
Public rstKnowledge As Recordset
Public rstLevel As Recordset
Public rstLiterature As Recordset
Public rstLiteratureInformation As Recordset
Public rstMemberName As Recordset
Public rstNatura2000 As Recordset
Public rstProcessFunction As Recordset
Public rstRedundance As Recordset
Public rstScale As Recordset
Public rstSoftware As Recordset
Public rstStaffMember As Recordset
Public rstUnits As Recordset
Dim mbEdit As Boolean
Dim mbAddNew As Boolean
Dim mbDataChanged As Boolean
Dim mvBookMark As Variant
_________________________________________________________________________
Private Sub Class_Initialize()
Dim con As New Connection
With con
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Open App.Path & "\IDEFIX1.MDB"
End With
With DataMembers
.Add "AUTHOR"
.Add "BASED_ON"
.Add "BIOREGION"
.Add "CHARACTERIZATION"
.Add "FORMULA"
.Add "FORMULA_DESCRIPTION"
.Add "FORMULA_PARAMETER"
.Add "FORMULA_RANGE"
.Add "HELP_TABLE1"
.Add "INDICATOR_GROUP"
.Add "INDICATOR_CATEGORY"
.Add "INSTITUTION"
.Add "INSTITUTION_TESTSITE"
.Add "KNOWLEDGE"
.Add "LEVEL"
.Add "LITERATURE"
.Add "LITERATURE_INFORMATION"
.Add "MEMBER_NAME"
.Add "NATURA_2000"
.Add "PROCESS_FUNCTION"
.Add "REDUNDANCE"
.Add "SCALE"
.Add "SOFTWARE"
.Add "STAFF_MEMBER"
.Add "STRUCTURAL_INDICATOR"
.Add "UNITS"
End With
Set rstAuthor = New Recordset
Set rstBasedOn = New Recordset
Set rstBioregion = New Recordset
Set rstCharacterization = New Recordset
Set rstFormula = New Recordset
Set rstFormulaDescription = New Recordset
Set rstFormulaParameter = New Recordset
Set rstFormulaRange = New Recordset
Set rstHelpTable1 = New Recordset
Set rstIndicatorGroup = New Recordset
Set rstIndicatorCategory = New Recordset
Set rstInstitution = New Recordset
Set rstInstitutionTestsite = New Recordset
Set rstKnowledge = New Recordset
Set rstLevel = New Recordset
Set rstLiterature = New Recordset
Set rstLiteratureInformation = New Recordset
Set rstMemberName = New Recordset
Set rstNatura2000 = New Recordset
Set rstProcessFunction = New Recordset
Set rstRedundance = New Recordset
Set rstScale = New Recordset
Set rstSoftware = New Recordset
Set rstStaffMember = New Recordset
Set rstStructuralIndicator = New Recordset
Set rstUnits = New Recordset
rstAuthor.Open "SELECT * FROM AUTHOR", con, _
adOpenStatic, adLockOptimistic
rstBasedOn.Open "SELECT * FROM BASED_ON", con, _
adOpenStatic, adLockOptimistic
rstBioregion.Open "SELECT * FROM BIOREGION", con, _
adOpenStatic, adLockOptimistic
rstCharacterization.Open "SELECT * FROM CHARACTERIZATION", con, _
adOpenStatic, adLockOptimistic
rstFormula.Open "SELECT * FROM FORMULA", con, _
adOpenStatic, adLockOptimistic
rstFormulaDescription.Open "SELECT * FROM FORMULA_DESCRIPTION", con, _
adOpenStatic, adLockOptimistic
rstFormulaParameter.Open "SELECT * FROM FORMULA_PARAMETER", con, _
adOpenStatic, adLockOptimistic
rstFormulaRange.Open "SELECT * FROM FORMULA_RANGE", con, _
adOpenStatic, adLockOptimistic
rstHelpTable1.Open "SELECT * FROM HELP_TABLE1", con, _
adOpenStatic, adLockOptimistic
rstIndicatorGroup.Open "SELECT * FROM INDICATOR_GROUP", con, _
adOpenStatic, adLockOptimistic
rstIndicatorCategory.Open "SELECT * FROM INDICATOR_CATEGORY", con, _
adOpenStatic, adLockOptimistic
rstInstitution.Open "SELECT * FROM INSTITUTION", con, _
adOpenStatic, adLockOptimistic
rstInstitutionTestsite.Open "SELECT * FROM INSTITUTION_TESTSITE", con, _
adOpenStatic, adLockOptimistic
rstKnowledge.Open "SELECT * FROM KNOWLEDGE", con, _
adOpenStatic, adLockOptimistic
rstLevel.Open "SELECT * FROM LEVEL", con, _
adOpenStatic, adLockOptimistic
rstLiterature.Open "SELECT * FROM LITERATURE", con, _
adOpenStatic, adLockOptimistic
rstLiteratureInformation.Open "SELECT * FROM LITERATURE_INFORMATION", con, _
adOpenStatic, adLockOptimistic
rstMemberName.Open "SELECT * FROM MEMBER_NAME", con, _
adOpenStatic, adLockOptimistic
rstNatura2000.Open "SELECT * FROM NATURA_2000", con, _
adOpenStatic, adLockOptimistic
rstProcessFunction.Open "SELECT * FROM PROCESS_FUNCTION", con, _
adOpenStatic, adLockOptimistic
rstRedundance.Open "SELECT * FROM REDUNDANCE", con, _
adOpenStatic, adLockOptimistic
rstScale.Open "SELECT * FROM SCALE", con, _
adOpenStatic, adLockOptimistic
rstSoftware.Open "SELECT * FROM SOFTWARE", con, _
adOpenStatic, adLockOptimistic
rstStaffMember.Open "SELECT * FROM STAFF_MEMBER", con, _
adOpenStatic, adLockOptimistic
rstUnits.Open "SELECT * FROM UNITS", con, _
adOpenStatic, adLockOptimistic
rstStructuralIndicator.Open "SELECT * FROM STRUCTURAL_INDICATOR ORDER BY struc_indicator_id", con, _
adOpenStatic, adLockOptimistic
End Sub
_________________________________________________________________________
Private Sub Class_GetDataMember(DataMember As String, Data As Object)
Select Case DataMember
Case "AUTHOR": Set Data = rstAuthor
Case "BASED_ON": Set Data = rstBasedOn
Case "BIOREGION": Set Data = rstBioregion
Case "CHARACTERIZATION": Set Data = rstCharacterization
Case "FORMULA": Set Data = rstFormula
Case "FORMULA_DESCRIPTION": Set Data = rstFormulaDescription
Case "FORMULA_PARAMETER": Set Data = rstFormulaParameter
Case "FORMULA_RANGE": Set Data = rstFormulaRange
Case "HELP_TABLE1": Set Data = rstHelpTable1
Case "INDICATOR_GROUP": Set Data = rstIndicatorGroup
Case "INDICATOR_CATEGORY": Set Data = rstIndicatorCategory
Case "INSTITUTION": Set Data = rstInstitution
Case "INSTITUTION_TESTSITE": Set Data = rstInstitutionTestsite
Case "KNOWLEDGE": Set Data = rstKnowledge
Case "LEVEL": Set Data = rstLevel
Case "LITERATURE": Set Data = rstLiterature
Case "LITERATURE_INFORMATION": Set Data = rstLiteratureInformation
Case "MEMBER_NAME": Set Data = rstMemberName
Case "NATURA_2000": Set Data = rstNatura2000
Case "PROCESS_FUNCTION": Set Data = rstProcessFunction
Case "REDUNDANCE": Set Data = rstRedundance
Case "SCALE": Set Data = rstScale
Case "SOFTWARE": Set Data = rstSoftware
Case "STAFF_MEMBER": Set Data = rstStaffMember
Case "STRUCTURAL_INDICATOR": Set Data = rstStructuralIndicator
Case "UNITS": Set Data = rstUnits
Case "": Set Data = rstStructuralIndicator
End Select
End Sub
_________________________________________________________________________
'(0)
Public Sub MoveFirst()
On Error GoTo MoveFirstError
rstStructuralIndicator.MoveFirst
mbDataChanged = False
Exit Sub
MoveFirstError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(1)
Public Sub MovePrevious()
On Error GoTo MovePreviousError
If Not rstStructuralIndicator.BOF Then rstStructuralIndicator.MovePrevious
If rstStructuralIndicator.BOF And rstStructuralIndicator.RecordCount > 0 Then
Beep
'moved off the end so go back
rstStructuralIndicator.MoveFirst
End If
'show the current record
mbDataChanged = False
Exit Sub
MovePreviousError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(2)
Public Sub MoveNext()
On Error GoTo MoveNextError
If Not rstStructuralIndicator.EOF Then rstStructuralIndicator.MoveNext
If rstStructuralIndicator.EOF And rstStructuralIndicator.RecordCount > 0 Then
Beep
'moved off the end so go back
rstStructuralIndicator.MoveLast
End If
'show the current record
mbDataChanged = False
Exit Sub
MoveNextError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(3)
Public Sub MoveLast()
On Error GoTo MoveLastError
rstStructuralIndicator.MoveLast
mbDataChanged = False
Exit Sub
MoveLastError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(4)
Public Sub Logout()
Unload frmStruc_Ind
frmWelcome.Show
End Sub
_________________________________________________________________________
'(5)
Public Sub Refresh()
'This is only needed for multi user applications
On Error GoTo RefreshErr
rstStructuralIndicator.Requery
Exit Sub
RefreshErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(6)
Public Sub DeleteRst()
On Error GoTo DeleteRstErr
With rstStructuralIndicator
If MsgBox("Are you sure you want to" & _
"delete the current Recordset?", 36, "Be Careful!"
= 6 Then
rstStructuralIndicator.Delete
rstStructuralIndicator.MoveNext: If rstStructuralIndicator.EOF Then rstStructuralIndicator.MoveLast
End If
End With
Exit Sub
DeleteRstErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(7)
Public Sub Edit()
On Error GoTo EditErr
frmStruc_Ind.lblStatus.Caption = "Edit Record"
mbEdit = True
SetButtons False
Exit Sub
EditErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(8)
Public Sub Cancel()
On Error Resume Next
SetButtons True
mbEdit = False
mbAddNew = False
rstStructuralIndicator.CancelUpdate
If mvBookMark > 0 Then
rstStructuralIndicator.Bookmark = mvBookMark
Else
rstStructuralIndicator.MoveFirst
End If
mbDataChanged = False
End Sub
_________________________________________________________________________
'(9)
Public Sub AddNew()
On Error GoTo AddNewErr
With rstStructuralIndicator
If Not (.BOF And .EOF) Then
mvBookMark = .Bookmark
End If
rstStructuralIndicator.AddNew
frmStruc_Ind.lblStatus.Caption = "Add new record"
mbAddNew = True
SetButtons False
End With
Exit Sub
AddNewErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(10)
Public Sub Update()
On Error GoTo UpdateErr
rstStructuralIndicator.UpdateBatch adAffectAll
If mbAddNew Then
rstStructuralIndicator.MoveLast 'move to the new record
End If
mbEdit = False
mbAddNew = False
SetButtons True
mbDataChanged = False
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
Private Sub SetButtons(bVal As Boolean)
frmStruc_Ind.cmdDBEvent(9).Visible = bVal 'Case 9: AddNew
frmStruc_Ind.cmdDBEvent(7).Visible = bVal 'Case 7: Edit
frmStruc_Ind.cmdDBEvent(10).Visible = Not bVal 'Case 10: Update
frmStruc_Ind.cmdDBEvent(8).Visible = Not bVal 'Case 8: Cancel
frmStruc_Ind.cmdDBEvent(6).Visible = bVal 'Case 6: DeleteRst
frmStruc_Ind.cmdDBEvent(4).Visible = bVal 'Case 4: Logout
frmStruc_Ind.cmdDBEvent(5).Visible = bVal 'Case 5: Refresh
frmStruc_Ind.cmdDBEvent(2).Enabled = bVal 'Case 2: MoveNext
frmStruc_Ind.cmdDBEvent(0).Enabled = bVal 'Case 0: MoveFirst
frmStruc_Ind.cmdDBEvent(3).Enabled = bVal 'Case 3: MoveLast
frmStruc_Ind.cmdDBEvent(1).Enabled = bVal 'Case 1: MovePrevious
End Sub
_________________________________________________________________________
Private Sub rstStructuralIndicator_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
frmStruc_Ind.lblStatus.Caption = "Data Set: " & CStr(rstStructuralIndicator.AbsolutePosition)
End Sub
_________________________________________________________________________
Private Sub rstStructuralIndicator_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
Dim bCancel As Boolean
Select Case adReason
Case adRsnAddNew
Case adRsnClose
Case adRsnDelete
Case adRsnFirstChange
Case adRsnMove
Case adRsnRequery
Case adRsnResynch
Case adRsnUndoAddNew
Case adRsnUndoDelete
Case adRsnUndoUpdate
Case adRsnUpdate
End Select
If bCancel Then adStatus = adStatusCancel
End Sub
_________________________________________________________________________
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If mbEdit Or mbAddNew Then Exit Sub
Select Case KeyCode
Case vbKeyEscape: eventhandler.Logout
Case vbKeyEnd: eventhandler.MoveLast
Case vbKeyHome: eventhandler.MoveFirst
Case vbKeyUp, vbKeyPageUp
If Shift = vbCtrlMask Then
eventhandler.MoveFirst
Else
eventhandler.MovePrevious
End If
Case vbKeyDown, vbKeyPageDown
If Shift = vbCtrlMask Then
eventhandler.MoveLast
Else
eventhandler.MoveNext
End If
End Select
End Sub
_________________________________________________________________________
Private Sub Class_Terminate()
Set rstStructuralIndicator = Nothing
'... alle anderen noch anhängen!!!
End Sub
_________________________________________________________________________
I have a problem with connecting a database with more then one table to a VB-Form (please find the attached code for detailed information).
The tables in the database are connected by using id`s. So when moving a recordset of the main entry forward, all records in the tables which are bounded to a control should move forward.
The main problem is, that I have tables I like to display in the GUI with datacombos, with checkboxes, with option buttons, with textfields and last but not least OLE controls for displaying MS Formula Manager 3.0 objects stored in the database.
The difficulty is, that I want not use the ADO control, so that I have to programm the steering process manually.
MANY THANKS for HELP
Form
_________________________________________________________________________
Public eventhandler As dBEvent
Private bindCol As BindingCollection
_________________________________________________________________________
Private Sub Form_Load()
Set eventhandler = New dBEvent 'eventhandler=classmodule
Set bindCol = New BindingCollection
'binding the textboxes in the main table STRUCTURAL_INDICATOR (rstStructuralIndicator) -- THIS WORKS FINE
With bindCol
Set .DataSource = eventhandler.rstStructuralIndicator
.Add txtStrucShortName(0), "Text", "struc_short_name"
.Add txtStrucShortName(1), "Text", "struc_short_name"
.Add txtStrucShortName(2), "Text", "struc_short_name"
.Add txtStrucShortName(3), "Text", "struc_short_name"
.Add txtStrucShortName(4), "Text", "struc_short_name"
.Add txtStrucShortName(5), "Text", "struc_short_name"
.Add txtStrucShortName(6), "Text", "struc_short_name"
.Add txtStrucShortName(7), "Text", "struc_short_name"
.Add txtStrucFullName(0), "Text", "struc_full_name"
.Add txtStrucFullName(1), "Text", "struc_full_name"
.Add txtStrucFullName(2), "Text", "struc_full_name"
.Add txtStrucFullName(3), "Text", "struc_full_name"
.Add txtStrucFullName(4), "Text", "struc_full_name"
.Add txtStrucFullName(5), "Text", "struc_full_name"
.Add txtStrucFullName(6), "Text", "struc_full_name"
.Add txtStrucFullName(7), "Text", "struc_full_name"
End With
'binding the dataCombo in the table INDICATOR_CATEGORY (rstIndicatorCategory) -- THIS WORKS ALSO FINE
With dbcCategory
Set .DataSource = eventhandler
.DataMember = "STRUCTURAL_INDICATOR
.DataField = "struc_indicator_id"
.RowMember = "INDICATOR_CATEGORY"
Set .RowSource = eventhandler
.BoundColumn = "struc_category_id"
.ListField = "category"
End With
'How to bind further textboxes with attributes in other tables (maybe like TABLE_XY) (rstXY) within the same database in relation to rstStructuralIndicator
???? (HERE I HAVE A PROBLEM)
'How to connect a checkbox getting the yes/no values from another table, and optionbuttons?
???? (HERE I HAVE A PROBLEM)
'How to establish a connection to a table with OLE Objects in it
???? (HERE I HAVE A PROBLEM)
Exit_:
Screen.MousePointer = vbNormal
On Error Resume Next
Exit Sub
ErrHandler:
Screen.MousePointer = vbNormal
MsgBox "Unerwarteter Fehler " & (Err.Number And &HFFFF&) & " in Prozedur 'Form_Load': " & Err.Description, vbCritical
Resume Exit_
End Sub
_________________________________________________________________________
dBEvent.cls
_________________________________________________________________________
Option Explicit
'Middle-Tier
'Datenquelle liefert mehrere Datenelemente
_________________________________________________________________________
Public WithEvents rstStructuralIndicator As Recordset
Public rstAuthor As Recordset
Public rstBasedOn As Recordset
Public rstBioregion As Recordset
Public rstCharacterization As Recordset
Public rstFormula As Recordset
Public rstFormulaDescription As Recordset
Public rstFormulaParameter As Recordset
Public rstFormulaRange As Recordset
Public rstHelpTable1 As Recordset
Public rstIndicatorGroup As Recordset
Public rstIndicatorCategory As Recordset
Public rstInstitution As Recordset
Public rstInstitutionTestsite As Recordset
Public rstKnowledge As Recordset
Public rstLevel As Recordset
Public rstLiterature As Recordset
Public rstLiteratureInformation As Recordset
Public rstMemberName As Recordset
Public rstNatura2000 As Recordset
Public rstProcessFunction As Recordset
Public rstRedundance As Recordset
Public rstScale As Recordset
Public rstSoftware As Recordset
Public rstStaffMember As Recordset
Public rstUnits As Recordset
Dim mbEdit As Boolean
Dim mbAddNew As Boolean
Dim mbDataChanged As Boolean
Dim mvBookMark As Variant
_________________________________________________________________________
Private Sub Class_Initialize()
Dim con As New Connection
With con
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Open App.Path & "\IDEFIX1.MDB"
End With
With DataMembers
.Add "AUTHOR"
.Add "BASED_ON"
.Add "BIOREGION"
.Add "CHARACTERIZATION"
.Add "FORMULA"
.Add "FORMULA_DESCRIPTION"
.Add "FORMULA_PARAMETER"
.Add "FORMULA_RANGE"
.Add "HELP_TABLE1"
.Add "INDICATOR_GROUP"
.Add "INDICATOR_CATEGORY"
.Add "INSTITUTION"
.Add "INSTITUTION_TESTSITE"
.Add "KNOWLEDGE"
.Add "LEVEL"
.Add "LITERATURE"
.Add "LITERATURE_INFORMATION"
.Add "MEMBER_NAME"
.Add "NATURA_2000"
.Add "PROCESS_FUNCTION"
.Add "REDUNDANCE"
.Add "SCALE"
.Add "SOFTWARE"
.Add "STAFF_MEMBER"
.Add "STRUCTURAL_INDICATOR"
.Add "UNITS"
End With
Set rstAuthor = New Recordset
Set rstBasedOn = New Recordset
Set rstBioregion = New Recordset
Set rstCharacterization = New Recordset
Set rstFormula = New Recordset
Set rstFormulaDescription = New Recordset
Set rstFormulaParameter = New Recordset
Set rstFormulaRange = New Recordset
Set rstHelpTable1 = New Recordset
Set rstIndicatorGroup = New Recordset
Set rstIndicatorCategory = New Recordset
Set rstInstitution = New Recordset
Set rstInstitutionTestsite = New Recordset
Set rstKnowledge = New Recordset
Set rstLevel = New Recordset
Set rstLiterature = New Recordset
Set rstLiteratureInformation = New Recordset
Set rstMemberName = New Recordset
Set rstNatura2000 = New Recordset
Set rstProcessFunction = New Recordset
Set rstRedundance = New Recordset
Set rstScale = New Recordset
Set rstSoftware = New Recordset
Set rstStaffMember = New Recordset
Set rstStructuralIndicator = New Recordset
Set rstUnits = New Recordset
rstAuthor.Open "SELECT * FROM AUTHOR", con, _
adOpenStatic, adLockOptimistic
rstBasedOn.Open "SELECT * FROM BASED_ON", con, _
adOpenStatic, adLockOptimistic
rstBioregion.Open "SELECT * FROM BIOREGION", con, _
adOpenStatic, adLockOptimistic
rstCharacterization.Open "SELECT * FROM CHARACTERIZATION", con, _
adOpenStatic, adLockOptimistic
rstFormula.Open "SELECT * FROM FORMULA", con, _
adOpenStatic, adLockOptimistic
rstFormulaDescription.Open "SELECT * FROM FORMULA_DESCRIPTION", con, _
adOpenStatic, adLockOptimistic
rstFormulaParameter.Open "SELECT * FROM FORMULA_PARAMETER", con, _
adOpenStatic, adLockOptimistic
rstFormulaRange.Open "SELECT * FROM FORMULA_RANGE", con, _
adOpenStatic, adLockOptimistic
rstHelpTable1.Open "SELECT * FROM HELP_TABLE1", con, _
adOpenStatic, adLockOptimistic
rstIndicatorGroup.Open "SELECT * FROM INDICATOR_GROUP", con, _
adOpenStatic, adLockOptimistic
rstIndicatorCategory.Open "SELECT * FROM INDICATOR_CATEGORY", con, _
adOpenStatic, adLockOptimistic
rstInstitution.Open "SELECT * FROM INSTITUTION", con, _
adOpenStatic, adLockOptimistic
rstInstitutionTestsite.Open "SELECT * FROM INSTITUTION_TESTSITE", con, _
adOpenStatic, adLockOptimistic
rstKnowledge.Open "SELECT * FROM KNOWLEDGE", con, _
adOpenStatic, adLockOptimistic
rstLevel.Open "SELECT * FROM LEVEL", con, _
adOpenStatic, adLockOptimistic
rstLiterature.Open "SELECT * FROM LITERATURE", con, _
adOpenStatic, adLockOptimistic
rstLiteratureInformation.Open "SELECT * FROM LITERATURE_INFORMATION", con, _
adOpenStatic, adLockOptimistic
rstMemberName.Open "SELECT * FROM MEMBER_NAME", con, _
adOpenStatic, adLockOptimistic
rstNatura2000.Open "SELECT * FROM NATURA_2000", con, _
adOpenStatic, adLockOptimistic
rstProcessFunction.Open "SELECT * FROM PROCESS_FUNCTION", con, _
adOpenStatic, adLockOptimistic
rstRedundance.Open "SELECT * FROM REDUNDANCE", con, _
adOpenStatic, adLockOptimistic
rstScale.Open "SELECT * FROM SCALE", con, _
adOpenStatic, adLockOptimistic
rstSoftware.Open "SELECT * FROM SOFTWARE", con, _
adOpenStatic, adLockOptimistic
rstStaffMember.Open "SELECT * FROM STAFF_MEMBER", con, _
adOpenStatic, adLockOptimistic
rstUnits.Open "SELECT * FROM UNITS", con, _
adOpenStatic, adLockOptimistic
rstStructuralIndicator.Open "SELECT * FROM STRUCTURAL_INDICATOR ORDER BY struc_indicator_id", con, _
adOpenStatic, adLockOptimistic
End Sub
_________________________________________________________________________
Private Sub Class_GetDataMember(DataMember As String, Data As Object)
Select Case DataMember
Case "AUTHOR": Set Data = rstAuthor
Case "BASED_ON": Set Data = rstBasedOn
Case "BIOREGION": Set Data = rstBioregion
Case "CHARACTERIZATION": Set Data = rstCharacterization
Case "FORMULA": Set Data = rstFormula
Case "FORMULA_DESCRIPTION": Set Data = rstFormulaDescription
Case "FORMULA_PARAMETER": Set Data = rstFormulaParameter
Case "FORMULA_RANGE": Set Data = rstFormulaRange
Case "HELP_TABLE1": Set Data = rstHelpTable1
Case "INDICATOR_GROUP": Set Data = rstIndicatorGroup
Case "INDICATOR_CATEGORY": Set Data = rstIndicatorCategory
Case "INSTITUTION": Set Data = rstInstitution
Case "INSTITUTION_TESTSITE": Set Data = rstInstitutionTestsite
Case "KNOWLEDGE": Set Data = rstKnowledge
Case "LEVEL": Set Data = rstLevel
Case "LITERATURE": Set Data = rstLiterature
Case "LITERATURE_INFORMATION": Set Data = rstLiteratureInformation
Case "MEMBER_NAME": Set Data = rstMemberName
Case "NATURA_2000": Set Data = rstNatura2000
Case "PROCESS_FUNCTION": Set Data = rstProcessFunction
Case "REDUNDANCE": Set Data = rstRedundance
Case "SCALE": Set Data = rstScale
Case "SOFTWARE": Set Data = rstSoftware
Case "STAFF_MEMBER": Set Data = rstStaffMember
Case "STRUCTURAL_INDICATOR": Set Data = rstStructuralIndicator
Case "UNITS": Set Data = rstUnits
Case "": Set Data = rstStructuralIndicator
End Select
End Sub
_________________________________________________________________________
'(0)
Public Sub MoveFirst()
On Error GoTo MoveFirstError
rstStructuralIndicator.MoveFirst
mbDataChanged = False
Exit Sub
MoveFirstError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(1)
Public Sub MovePrevious()
On Error GoTo MovePreviousError
If Not rstStructuralIndicator.BOF Then rstStructuralIndicator.MovePrevious
If rstStructuralIndicator.BOF And rstStructuralIndicator.RecordCount > 0 Then
Beep
'moved off the end so go back
rstStructuralIndicator.MoveFirst
End If
'show the current record
mbDataChanged = False
Exit Sub
MovePreviousError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(2)
Public Sub MoveNext()
On Error GoTo MoveNextError
If Not rstStructuralIndicator.EOF Then rstStructuralIndicator.MoveNext
If rstStructuralIndicator.EOF And rstStructuralIndicator.RecordCount > 0 Then
Beep
'moved off the end so go back
rstStructuralIndicator.MoveLast
End If
'show the current record
mbDataChanged = False
Exit Sub
MoveNextError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(3)
Public Sub MoveLast()
On Error GoTo MoveLastError
rstStructuralIndicator.MoveLast
mbDataChanged = False
Exit Sub
MoveLastError:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(4)
Public Sub Logout()
Unload frmStruc_Ind
frmWelcome.Show
End Sub
_________________________________________________________________________
'(5)
Public Sub Refresh()
'This is only needed for multi user applications
On Error GoTo RefreshErr
rstStructuralIndicator.Requery
Exit Sub
RefreshErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(6)
Public Sub DeleteRst()
On Error GoTo DeleteRstErr
With rstStructuralIndicator
If MsgBox("Are you sure you want to" & _
"delete the current Recordset?", 36, "Be Careful!"
= 6 ThenrstStructuralIndicator.Delete
rstStructuralIndicator.MoveNext: If rstStructuralIndicator.EOF Then rstStructuralIndicator.MoveLast
End If
End With
Exit Sub
DeleteRstErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(7)
Public Sub Edit()
On Error GoTo EditErr
frmStruc_Ind.lblStatus.Caption = "Edit Record"
mbEdit = True
SetButtons False
Exit Sub
EditErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(8)
Public Sub Cancel()
On Error Resume Next
SetButtons True
mbEdit = False
mbAddNew = False
rstStructuralIndicator.CancelUpdate
If mvBookMark > 0 Then
rstStructuralIndicator.Bookmark = mvBookMark
Else
rstStructuralIndicator.MoveFirst
End If
mbDataChanged = False
End Sub
_________________________________________________________________________
'(9)
Public Sub AddNew()
On Error GoTo AddNewErr
With rstStructuralIndicator
If Not (.BOF And .EOF) Then
mvBookMark = .Bookmark
End If
rstStructuralIndicator.AddNew
frmStruc_Ind.lblStatus.Caption = "Add new record"
mbAddNew = True
SetButtons False
End With
Exit Sub
AddNewErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
'(10)
Public Sub Update()
On Error GoTo UpdateErr
rstStructuralIndicator.UpdateBatch adAffectAll
If mbAddNew Then
rstStructuralIndicator.MoveLast 'move to the new record
End If
mbEdit = False
mbAddNew = False
SetButtons True
mbDataChanged = False
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
_________________________________________________________________________
Private Sub SetButtons(bVal As Boolean)
frmStruc_Ind.cmdDBEvent(9).Visible = bVal 'Case 9: AddNew
frmStruc_Ind.cmdDBEvent(7).Visible = bVal 'Case 7: Edit
frmStruc_Ind.cmdDBEvent(10).Visible = Not bVal 'Case 10: Update
frmStruc_Ind.cmdDBEvent(8).Visible = Not bVal 'Case 8: Cancel
frmStruc_Ind.cmdDBEvent(6).Visible = bVal 'Case 6: DeleteRst
frmStruc_Ind.cmdDBEvent(4).Visible = bVal 'Case 4: Logout
frmStruc_Ind.cmdDBEvent(5).Visible = bVal 'Case 5: Refresh
frmStruc_Ind.cmdDBEvent(2).Enabled = bVal 'Case 2: MoveNext
frmStruc_Ind.cmdDBEvent(0).Enabled = bVal 'Case 0: MoveFirst
frmStruc_Ind.cmdDBEvent(3).Enabled = bVal 'Case 3: MoveLast
frmStruc_Ind.cmdDBEvent(1).Enabled = bVal 'Case 1: MovePrevious
End Sub
_________________________________________________________________________
Private Sub rstStructuralIndicator_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
frmStruc_Ind.lblStatus.Caption = "Data Set: " & CStr(rstStructuralIndicator.AbsolutePosition)
End Sub
_________________________________________________________________________
Private Sub rstStructuralIndicator_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
Dim bCancel As Boolean
Select Case adReason
Case adRsnAddNew
Case adRsnClose
Case adRsnDelete
Case adRsnFirstChange
Case adRsnMove
Case adRsnRequery
Case adRsnResynch
Case adRsnUndoAddNew
Case adRsnUndoDelete
Case adRsnUndoUpdate
Case adRsnUpdate
End Select
If bCancel Then adStatus = adStatusCancel
End Sub
_________________________________________________________________________
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If mbEdit Or mbAddNew Then Exit Sub
Select Case KeyCode
Case vbKeyEscape: eventhandler.Logout
Case vbKeyEnd: eventhandler.MoveLast
Case vbKeyHome: eventhandler.MoveFirst
Case vbKeyUp, vbKeyPageUp
If Shift = vbCtrlMask Then
eventhandler.MoveFirst
Else
eventhandler.MovePrevious
End If
Case vbKeyDown, vbKeyPageDown
If Shift = vbCtrlMask Then
eventhandler.MoveLast
Else
eventhandler.MoveNext
End If
End Select
End Sub
_________________________________________________________________________
Private Sub Class_Terminate()
Set rstStructuralIndicator = Nothing
'... alle anderen noch anhängen!!!
End Sub
_________________________________________________________________________
