VB Class Implementation with Pseudo Inheritance


This is an interesting example and simply shows that inheritance is sort-of possible using Visual Basic. There is another method using the Implements keyword. However, the implements keyword requires a lot of duplication of code. I am sure that someone out there has a better way of implementing inheritance in Visual Basic. I would like to know how to do inheritance properly if possible. Please let me know.


RecordSet Class

Option Explicit

Public Sub MoveFirst()
'
End Sub

Public Sub MoveLast()
'
End Sub

Public Sub MovePrevious()
'
End Sub

Public Sub MoveNext()
'
End Sub

Search Module

Option Explicit

Public Sub MoveFirst(TheRecordset As CRecordset)
    TheRecordset.MoveFirst
End Sub

Public Sub MoveLast(TheRecordset As CRecordset)
    TheRecordset.MoveLast
End Sub

Public Sub MoveNext(TheRecordset As CRecordset)
    TheRecordset.MoveNext
End Sub

Public Sub MovePrevious(TheRecordset As CRecordset)
    TheRecordset.MovePrevious
End Sub

Element Class (a relational database table)

Option Explicit

Implements CRecordset

Public trans_ic As String
Public trans_set As String
Public trans_type As Integer ' first char of posno (header/detail/summary
Public posno As String
Public Segment As String
Public Element As Integer
Public composite As Integer
Public usage As String
Public typ As String
Public min_len As Integer
Public max_len As Integer
Public data_element As String
Public valid_values As String
Public depend As String
Public special As String
Public element_name As String

Public Event DataChanged()

Private m_Elements As Recordset
Private m_Database As Database

Public Sub CRecordset_MovePrevious()
    
    On Error GoTo ErrorHandler
    
    If Not m_Elements.BOF Then
        m_Elements.MovePrevious
        Reload_Members
    End If
    Exit Sub

ErrorHandler:
    MsgBox Err.Number + ":" + Err.description
    
End Sub

Public Sub CRecordset_MoveNext()
    
    On Error GoTo ErrorHandler
    
    If Not m_Elements.EOF Then
        m_Elements.MoveNext
        Reload_Members
    End If
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Number + ":" + Err.description

End Sub

Public Sub CRecordset_MoveLast()
    
    On Error GoTo ErrorHandler

    m_Elements.MoveLast
    Reload_Members
    Exit Sub

ErrorHandler:
    MsgBox Err.Number + ":" + Err.description
    
End Sub

Public Sub CRecordset_MoveFirst()

    On Error GoTo ErrorHandler

    m_Elements.MoveFirst
    Reload_Members
    Exit Sub

ErrorHandler:
    MsgBox Err.Number + ":" + Err.description

End Sub

Private Sub Class_Initialize()

Dim i As Integer

    On Error GoTo ErrorHandler

    Set m_Database = Workspaces(0).OpenDatabase("c:\visualbasic\validate\database\validate.mdb")
    Set m_Elements = m_Database.OpenRecordset("select * from element where trans_ic='003050' and trans_set='840'", dbOpenSnapshot)
    Exit Sub
    
ErrorHandler:
    MsgBox "There was a problem opening either the Validate database or the Element table", vbExclamation, "Problem"
    
End Sub

Private Sub Class_Terminate()

On Error Resume Next

    m_Elements.Close
    m_Database.Close
    
End Sub

Private Sub Reload_Members()

On Error GoTo ErrorHandler

    If m_Elements.BOF = False And m_Elements.EOF = False Then
        With m_Elements
            trans_ic = "" & .Fields("trans_ic")
            trans_set = "" & .Fields("trans_set")
            posno = "" & .Fields("posno")
            Segment = "" & .Fields("segment")
            Element = .Fields("element")
            composite = .Fields("composite")
            usage = "" & .Fields("usage")
            typ = "" & .Fields("type")
            min_len = .Fields("min_len")
            max_len = .Fields("max_len")
            data_element = "" & .Fields("data_element")
            valid_values = "" & .Fields("valid_values")
            depend = "" & .Fields("depend")
            special = "" & .Fields("special")
            element_name = "" & .Fields("element_name")
        End With
        RaiseEvent DataChanged
    End If
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Number + ":" + Err.description
    
End Sub

The Get Element Class

Option Explicit

Private WithEvents DataElements As CDataElements

Private Type DataElementRecord
    trans_ic As String
    data_element As String
    value As String
    description As String
End Type

Private DataElement As DataElementRecord

Private Sub Class_Initialize()
    Set DataElements = New CDataElements
End Sub

Static Function FirstDataElement()
    MoveFirst DataElements
    FirstDataElement = DataElement
End Function

Static Function LastDataElement()
    MoveLast DataElements
    LastDataElement = DataElement
End Function

Static Function NextDataElement()
    MoveNext DataElements
    NextDataElement = DataElement
End Function

Static Function PreviousDataElement()
    MovePrevious DataElements
    PreviousDataElement = DataElement
End Function

Private Sub DataElements_DataChanged()
    On Error GoTo ErrorHandler
    With DataElements
        DataElement.trans_ic = .trans_ic
        DataElement.data_element = .data_element
        DataElement.value = .value
        DataElement.description = .description
    End With
    Exit Sub
ErrorHandler:
    MsgBox Err.Number + ":" + Err.description
End Sub