Visual Basic 4 Power Pack/Visual_Basic4_Power_Pack.bin/vb4files/dbawarco/dbawarco.cls

Text File | 1996-11-20 | 40.5 KB | 1,151 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DBAwareCollection"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
Option Explicit
'
' DBAwareCollection is a database-aware Collection class
'     supplemental for Microsoft Visual Basic 4.0
'
' (c) Copyright 1995 Abe Fitzpatrick,
'     All Rights Reserved
'     Cannot be distributed or sold without permission
'
' Application Requirements (Database level)
'   Each of the supported Tables must have a Column as follows:
'       Name: ObjectID
'       Type: Counter
'   Table "DBAwareObjectLinks"
'   Application Tables must be defined or attached to same
'       Database used to contain Table "DBAwareObjectLinks"
'
' Application Requirements (Project level)
'   DBAwareCollection.cls
'   DBAwareObjectLink.cls
'
' Application Requirements (Class Module level)
'   Public ObjectID as Long
'       (must be mapped to Table.ObjectID)
'   Private MyCollection As New DBAwareCollection
'   Public MyDatabase as Database
'   Private Sub Class_Initialize:
'       ObjectID = -1
'       possibly more, as needed
'   Public Function InitializeFromRecordSet(RecordSet) as <Me>
'   Public Function InitializeRecordSet(RecordSet) As Long (value of Err)
'   Public Function NewInstanceOfMyClass() as <Me>
'   Public Function ObjectType() As String
'   Public Function TableName() as String
'   Public Function <CollectionName>(Optional ByVal ObjectID As Variant) As Variant
'
' Application Requirements (General)
'   Application must prepare a Database object for use
'   Application must provide DBAwareCollection with the prepared
'       Database object using any of the following methods:
'       1.  the Public Property Set Database method,
'       2.  the Database:= named parameter of the
'               InstantiateFromDatabase method
'       3.  the Database:= named parameter of the
'               SetDatabaseParameters method
'
' Application Recommendations (General)
'   Each object which contains a DBAwareCollection should
'       have a corresponding method named "Add<ContainedObjectType>"
'       (e.g., "AddPerson", "AddAddress", etc.)

Private pvtSampleObject As Object
Private pvtParentObject As Object
Private pvtCollection As Collection
Private pvtDBAwareObjectLink As New DBAwareObjectLink
Private pvtSampleObjectTableName As String
Private pvtSampleObjectObjectType As String
Private pvtParentObjectTableName As String
Private pvtParentObjectObjectType As String
Private pvtDBAwareObjectLinkTableName As String

Private pvtDatabase As Database
Private pvtRecordSet As RecordSet
Private pvtSQLStatement As String
Private pvtWhereClause As String
Private pvtOrderByClause As String
Private pvtCollectionEmulationMode As Boolean
Private pvtRecordSetProvidedByUser As Boolean

Private pvtDBHasBeenReferenced As Long
Private pvtHighestObjectID As Long
Private RC As Long

Private Const pvtReceiverDoesNotSupportThisMethod = 438
Public Function Add(Optional ByVal Item As Variant, Optional ByVal Key As Variant, Optional Parent As Variant, Optional ByVal After As Variant, Optional ByVal NoInsert As Variant) As DBAwareCollection
Attribute Add.VB_Description = "Add an item to the collection.  Automatically inserts the item into the associated table.  See the VB Programmer's Manual for details"
' Add the new Item to the collection and
'   return the collection

    Dim tempSuppressInsert As Boolean

    On Local Error Resume Next

' bullet-proofing
    If IsMissing(Item) Or IsMissing(Parent) Then
        pvtErrorMessage pvtName & " cannot process the '.Add' method for this object because either the 'Item:=' or the 'Parent:=' parameter is missing"
        Set Add = Me
        Exit Function
    End If

' support database-free emulation of the VB Collection Class
    tempSuppressInsert = False
    If Item.TableName = "" Or Err = 438 Then
        pvtCollectionEmulationMode = True
        tempSuppressInsert = True
    End If
    If Not IsMissing(NoInsert) Then
        If NoInsert = True Then
            tempSuppressInsert = True
        End If
    End If

' if in an Insert-capable mode
    If tempSuppressInsert = False Then

' if Item.ObjectID doesn't already have a value
'   (meaning that it has never been inserted in
'   the database),
        If Item.ObjectID <= 0 Then

' insert Item and set Item.ObjectID
            Item.ObjectID = pvtDBInsert( _
                                 Item:=Item)
        End If

' else, if the ObjectID doesn't already have a value
'   assign an artificial ObjectID
    Else
        pvtHighestObjectID = pvtHighestObjectID + 1
        Item.ObjectID = pvtHighestObjectID
    End If

' save the HighestObjectID encountered
    If Item.ObjectID > pvtHighestObjectID Then
        pvtHighestObjectID = Item.ObjectID
    End If

' use the Key:= if it was provided and it was
'   of Type(Long)
    If IsMissing(Key) Or Key = 0 Or Err = 13 Then
        pvtAddItemToCollection _
            Item:=Item, _
            Key:=CStr(Item.ObjectID), _
            After:=After

' else, use the Item.ObjectID
    Else
        pvtAddItemToCollection _
            Item:=Item, _
            Key:=Key, _
            After:=After
    End If

' link the Item to its Parent object
'   (in the database)
    If Not IsMissing(Parent) And pvtCollectionEmulationMode = False Then
        RC = pvtDBAwareObjectLink.LinkParentObjectToChildObject( _
            Parent:=Parent, _
            Child:=Item)
    End If

    Set Add = Me
End Function


Public Function AddWithoutDBInsert(Optional ByVal Item As Variant, Optional ByVal Key As Variant, Optional Parent As Variant, Optional ByVal After As Variant, Optional ByVal NoInsert As Variant) As DBAwareCollection
Attribute AddWithoutDBInsert.VB_Description = "Add an item to the collection.  Does not automatically insert the item into the associated table"
' Add Item to the DBAwareCollection, but without
'   inserting it into the database

    Set AddWithoutDBInsert = Add( _
                                    Item:=Item, _
                                    Key:=Key, _
                                    Parent:=Parent, _
                                    After:=After, _
                                    NoInsert:=True)

End Function

Public Function CloneRecordSet() As RecordSet
Attribute CloneRecordSet.VB_Description = "Returns a Clone of the internally maintained RecordSet object"
    Set CloneRecordSet = pvtRecordSet.Clone()
End Function

Public Function CollectionIndex(Optional ByVal Item As Variant) As Long
Attribute CollectionIndex.VB_Description = "Returns the index (1 - n) of the item in the collection"
' Return the Collection Index of Item

    Dim tempItem As Object
    Dim I As Long

    On Local Error Resume Next

    I = 1
    For Each tempItem In pvtCollection
        If tempItem.ObjectID = Item.ObjectID Then
            If Err = 0 Then ' for some reason this doesn't work if placed in the above statement as an "And"
                CollectionIndex = I
                Exit Function
            End If
        End If

        I = I + 1
    Next tempItem

    CollectionIndex = -1
End Function

Public Function Count() As Long
Attribute Count.VB_Description = "Returns a count of the number of items currently in the collection.  See the VB Programmer's Manual for details"
    Count = pvtCollection.Count
End Function

Public Property Set Database(Database As Database)
Attribute Database.VB_Description = "Sets the database property"

    If Not IsMissing(Database) Then
        pvtReceiveGeneralParameters _
            Database:=Database

        pvtCollectionEmulationMode = False
    End If

End Property

Public Function DatabaseHasBeenReferenced() As Long
Attribute DatabaseHasBeenReferenced.VB_Description = "Returns turue or false, depending on whether or not the DBAwareCollection has referenced the database to attempt to instantiate the collection of contained objects"
' Returns aBoolean, depending on whether or not the
'   Database has been referenced as of yet for this
'   DBAwareCollection

    DatabaseHasBeenReferenced = pvtDBHasBeenReferenced
End Function

Public Function InstantiateFromDatabase(Optional ByVal Database As Variant, Optional ByVal SampleObject As Variant, Optional ByVal Parent As Variant, Optional ByVal WhereClause As Variant, Optional ByVal SQL As Variant, Optional ByVal OrderByClause As Variant) As DBAwareCollection
Attribute InstantiateFromDatabase.VB_Description = "Returns a DBAwareCollection which has been instantiated with a collection of instantiated objects, according to the contents of the associated table"
' Returns a DBAwareCollection of objects which have been
'   instantiated from data found in a database
'   table meeting the criteria specified in any of
'   the following methods:
'       a complete SQL statement can be provided;
'       a Where Clause can be provided;
'       a Parent Object can be provided;

    Dim tempRow As Object
    Dim newChildObject As Object
    Dim tempIndex As Long

    On Local Error Resume Next

    Set InstantiateFromDatabase = Nothing
    pvtRecordSetProvidedByUser = False

' test SampleObject for Database-readiness
    If Not IsMissing(SampleObject) Then
        If (SampleObject.TableName = "" Or Err = 438) Then
            pvtCollectionEmulationMode = True
        End If
    End If

    pvtReceiveGeneralParameters _
        Database:=Database, _
        SampleObject:=SampleObject, _
        Parent:=Parent, _
        WhereClause:=WhereClause, _
        OrderByClause:=OrderByClause, _
        SQL:=SQL

' determine the usability of the parameters
    If Not pvtCheckDatabase() _
    Or Not pvtCheckSQLAccessibility() _
    Then
        Exit Function
    End If

' open a RecordSet containing the desired rows
    Set pvtRecordSet = pvtDBSelect( _
                            pvtCreateSQLStatement())

' create the objects from the contents of the
'   RecordSet
    Set pvtCollection = _
        pvtInstantiateObjectsFromRecordSet( _
            RecordSet:=pvtRecordSet, _
            Collection:=pvtCollection)

InstantiateFromDatabase_Exit:
    Set InstantiateFromDatabase = Me
End Function


Public Function Item(Optional ByVal ObjectID As Variant) As Variant
Attribute Item.VB_Description = "Returns either the entire DBAwareCollection (as a collection) or a specific item.  See the VB Programmer's Manual for details"
' Returns either the entire collection or a
'   specific item in the collection

    On Local Error Resume Next

' determine the usability of the current state
    If Not pvtCollectionEmulationMode Then
        If Not pvtCheckDatabase() _
        Or Not pvtCheckSQLAccessibility() _
        Or Not pvtCheckCollection() _
        Then
            Exit Function
        End If
    End If

' check for a request for a specific Object
    If Not IsMissing(ObjectID) Then
        Set Item = pvtCollection.Item(ObjectID)
        If Err = 5 Then
            Set Item = Nothing
            Exit Function
        End If
    Else
        Set Item = Me
    End If
End Function


Public Function Name() As String
Attribute Name.VB_Description = "Returns the name of the DBAwareCollection"
' Returns "DBAwareCollection", the name of
'   this object

    Name = pvtName
End Function

Private Function pvtAddItemToCollection(Optional ByVal Item As Variant, Optional ByVal Key As Variant, Optional ByVal After As Variant) As Collection
Attribute pvtAddItemToCollection.VB_Description = "(Private) adds an item to the internally managed collection"
' Return the DBAwareCollection after having added
'   Item.  Take into account the impact of the
'   After parameter

    Dim tempAfter As Long

    On Local Error Resume Next

' set default After value
    tempAfter = pvtCollection.Count

' use any specified After value
    If Not IsMissing(After) Then
        If After <= pvtCollection.Count Then
            tempAfter = After
        End If
    End If

' insert somewhere after the first item
    If tempAfter > 0 Then
        pvtCollection.Add _
            Item:=Item, _
            Key:=CStr(Item.ObjectID), _
            After:=tempAfter

' insert before the first item
    ElseIf pvtCollection.Count > 0 Then
        pvtCollection.Add _
            Item:=Item, _
            Key:=CStr(Item.ObjectID), _
            Before:=1

' insert as the first item
    Else
        pvtCollection.Add _
            Item:=Item, _
            Key:=CStr(Item.ObjectID)
    End If

    Set pvtAddItemToCollection = pvtCollection
End Function

Private Function pvtBuildSQLStatementFromWhereClause(Optional WhereClause As Variant) As String
Attribute pvtBuildSQLStatementFromWhereClause.VB_Description = "(Private) returns an SQL Select statement which includes a user-specified Where clause.  The SQL statement should be appropriate for retrieving all of the items contained within the specified parent object"
' Return an SQL Statement which uses WhereClause to
'   select the desired rows

    Dim SQLStatement As String

    On Local Error Resume Next

' ask the SampleObject for certain critical services
    pvtSampleObjectTableName = pvtSampleObject.TableName
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "Object does not support the method 'TableName'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    pvtSampleObjectObjectType = pvtSampleObject.ObjectType
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "Object does not support the method 'ObjectType'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    On Local Error Resume Next

    SQLStatement = _
        "SELECT DISTINCTROW " & _
        pvtSampleObjectTableName & ".* FROM " & _
        pvtSampleObjectTableName & " WHERE " & _
        WhereClause
    SQLStatement = SQLStatement & _
        pvtConcatenateOrderByClause( _
            SQL:=SQLStatement, _
            OrderByClause:=pvtOrderByClause)

    pvtBuildSQLStatementFromWhereClause = SQLStatement
End Function


Private Function pvtBuildSQLStatementFromParent(Optional ByVal Parent As Variant) As String
Attribute pvtBuildSQLStatementFromParent.VB_Description = "(Private) returns an SQL Select statement which can be used to retrieve all of the items contained within the specified parent object"
' Return an SQL Statement which retrieves rows
'   of the child table based on the value of
'   the Parent object

    Dim SQLStatement As String

' ask the SampleObject for certain critical services
    pvtSampleObjectTableName = pvtSampleObject.TableName
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The provided 'Sample' object does not support the method 'TableName'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    pvtSampleObjectObjectType = pvtSampleObject.ObjectType
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The provided 'Sample' object does not support the method 'ObjectType'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    pvtParentObjectTableName = pvtParentObject.TableName
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The provided 'Parent' object does not support the method 'TableName'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    pvtParentObjectObjectType = pvtParentObject.ObjectType
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The provided 'Parent' object does not support the method 'ObjectType'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    pvtDBAwareObjectLinkTableName = pvtDBAwareObjectLink.TableName()
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The DBAwareObjectLink Object is invalid (is missing method 'TableName'.)" & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

    On Local Error Resume Next

' (SQL Statement modeled in MS Access)
'SELECT DISTINCTROW
'        Persons.* FROM (DBAwareObjectLinks INNER JOIN
'        Company ON DBAwareObjectLinks.FromObjectID =
'       Company.ObjectID) INNER JOIN
'       Persons ON DBAwareObjectLinks.ToObjectID =
'       Persons.ObjectID WHERE ((DBAwareObjectLinks.FromObjectType="
'       Company") AND (DBAwareObjectLinks.ToObjectType="
'       Person") AND (
'       Company.ObjectID=
'       1));
    SQLStatement = _
        "SELECT DISTINCTROW " & _
        pvtSampleObjectTableName & ".* FROM (" & pvtDBAwareObjectLinkTableName & " INNER JOIN " & _
        pvtParentObjectTableName & " ON " & pvtDBAwareObjectLinkTableName & ".FromObjectID = " & _
        pvtParentObjectTableName & ".ObjectID) INNER JOIN " & _
        pvtSampleObjectTableName & " ON " & pvtDBAwareObjectLinkTableName & ".ToObjectID = " & _
        pvtSampleObjectTableName & ".ObjectID WHERE ((" & pvtDBAwareObjectLinkTableName & ".FromObjectType='"
    SQLStatement = SQLStatement & _
        pvtParentObjectObjectType & "') AND (" & pvtDBAwareObjectLinkTableName & ".ToObjectType='" & _
        pvtSampleObjectObjectType & "') AND (" & _
        pvtParentObjectTableName & ".ObjectID=" & _
        CStr(pvtParentObject.ObjectID) & "))"
    SQLStatement = SQLStatement & _
        pvtConcatenateOrderByClause( _
            SQL:=SQLStatement, _
            OrderByClause:=pvtOrderByClause)

    pvtBuildSQLStatementFromParent = SQLStatement
End Function

Private Function pvtCheckCollection() As Long
Attribute pvtCheckCollection.VB_Description = "(Private) internal function"
' Verify that the pvtCollection has been
'   instantiated

    If pvtCollection Is Nothing Then
        pvtErrorMessage pvtName & " cannot provide meaningfuly functionality because the collection has not been built."
        pvtCheckCollection = False
        Exit Function
    End If

    pvtCheckCollection = True
End Function

Private Function pvtCheckRecordSet() As Long
Attribute pvtCheckRecordSet.VB_Description = "(Private) internal function"
' Verify that the RecordSet has been initialized

    If pvtRecordSet Is Nothing Then
        pvtErrorMessage pvtName & " cannot insert data into the database because the collection was never built."
        pvtCheckRecordSet = False
        Exit Function
    End If

    pvtCheckRecordSet = True
End Function

Private Function pvtCheckSQLAccessibility() As Long
Attribute pvtCheckSQLAccessibility.VB_Description = "(Private) internal function"
' Determine whether or not the desired table data
'   can be derived, given the information provided

    If (pvtParentObject Is Nothing _
    And pvtWhereClause = "" _
    And pvtSQLStatement = "" _
    ) Then
        pvtErrorMessage pvtName & " cannot perform object instantiations without having been provided with either an SQL:=, a WhereClause:= or a Parent:= ."
        pvtCheckSQLAccessibility = False
        Exit Function
    End If

    pvtCheckSQLAccessibility = True
End Function


Private Function pvtConcatenateOrderByClause(Optional ByVal SQL As Variant, Optional ByVal OrderByClause As Variant) As String
' Return eith er null string or an OrderBy clause
'   including the leading "Order By"

    If OrderByClause <> "" Then
        pvtConcatenateOrderByClause = _
            " ORDER BY " & _
            OrderByClause
    Else
        pvtConcatenateOrderByClause = ""
    End If

End Function


Private Function pvtCreateSQLStatement() As String
Attribute pvtCreateSQLStatement.VB_Description = "(Private) internal function"
' Evaluate the available information and create
'   an SQL Statement to access the desired rows

' decide how to acquire an SQL Statement:
'   first try the SQL Statement
    If pvtSQLStatement = "" Then

'   next, build the SQL Statement from the
'       Where Clause
        If pvtWhereClause <> "" Then
            pvtSQLStatement = _
                pvtBuildSQLStatementFromWhereClause( _
                    WhereClause:=pvtWhereClause)

'   otherwise, use the Parent Object
        Else
            pvtSQLStatement = _
                pvtBuildSQLStatementFromParent( _
                    Parent:=pvtParentObject)
        End If
    End If

    pvtCreateSQLStatement = pvtSQLStatement
End Function

Private Function pvtDBInsert(Optional ByVal Item As Variant) As Long
Attribute pvtDBInsert.VB_Description = "(Private) inserts the item from the associated table"
' Insert Item into the table, then return
'   its ObjectID value

    Dim tempObjectErr As Long
    Dim tempBookMark As String

    On Local Error Resume Next

    If Not pvtCheckRecordSet() Then
        pvtDBInsert = False
        Exit Function
    End If

' prepare a new record area
    pvtRecordSet.AddNew

' have the Item populate the RecordSet.
'   check for errors on that end
    Err = 0
    tempObjectErr = Item.InitializeRecordSet(pvtRecordSet)
    If tempObjectErr <> 0 _
    Or Err <> 0 Then
        If Err = pvtReceiverDoesNotSupportThisMethod Or tempObjectErr = pvtReceiverDoesNotSupportThisMethod Then
            pvtErrorMessage "Object does not support the method 'InitializeRecordSet'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
        End If
        pvtDBInsert = 0
        Exit Function
    End If

' execute the update
    pvtRecordSet.Update

' return the ObjectID
'    pvtRecordSet.Requery
    If Err = 0 Then
        tempBookMark = pvtRecordSet.LastModified
        pvtRecordSet.Bookmark = tempBookMark
    End If
    pvtDBInsert = pvtRecordSet("ObjectID")
End Function


Private Function pvtErrorMessage(Optional ByVal ErrorMessage As Variant) As Long
Attribute pvtErrorMessage.VB_Description = "(Private) internal function"

    Dim RC As Long

    RC = MsgBox( _
        ErrorMessage & vbCrLf & "Err=" & Err & ", Msg=" & Error(Err), _
        vbOK + vbExclamation, _
        pvtName & " Run-Time Error")
    Err = 0
    pvtErrorMessage = RC
End Function
Private Function pvtDBSelect(Optional ByVal SQL As Variant) As RecordSet
Attribute pvtDBSelect.VB_Description = "(Private) selects the contained items from the associated table"
' Process the SQL Select statement and return
'   a RecordSet

' open a RecordSet containing the desired rows
    Set pvtDBSelect = pvtDatabase. _
                        OpenRecordset( _
                            SQL, _
                            dbOpenDynaset)

    pvtDBHasBeenReferenced = True
End Function

Private Function pvtDBUpdate(Optional ByVal Item As Variant) As DBAwareCollection
Attribute pvtDBUpdate.VB_Description = "(Private) updates the item from the associated table"
' Update the Item in the table

    On Local Error Resume Next

    If pvtRecordSet Is Nothing Then
        pvtErrorMessage pvtName & " cannot update data in the database because the collection was never built."
        Set pvtDBUpdate = Nothing
        Exit Function
    End If

' prepare a new record area
    pvtRecordSet.Edit

' have the Item populate the RecordSet
    Item.InitializeRecordSet (pvtRecordSet)
    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "Object does not support the method 'InitializeRecordSet'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

' execute the update
    pvtRecordSet.Update

' return the colection
    Set pvtDBUpdate = Me
End Function

Private Function pvtDBDelete() As Long
Attribute pvtDBDelete.VB_Description = "(Private) deletes the item from the associated table"
' Update the Item in the table

    On Local Error Resume Next

' bullet-proofing
    If pvtRecordSet Is Nothing Then
        pvtErrorMessage pvtName & " cannot delete data in the database because the collection was never built."
        Set pvtDBUpdate = Nothing
        Exit Function
    End If

' delete the record
    Err = 0
    pvtRecordSet.Delete

    If Err = 0 Then
        pvtDBDelete = True
    Else
        pvtDBDelete = False
    End If
End Function

Private Function pvtInstantiateObjectsFromRecordSet(Optional ByVal RecordSet As Variant, Optional ByVal Collection) As Collection
' Return a Collection of objects which have been
'   instantiated from data found in RecordSet

    Dim tempRow As Object
    Dim newChildObject As Object
    Dim tempIndex As Long
    Dim tempCollection As New Collection

    On Local Error Resume Next

' process the RecordSet
    While Not RecordSet.EOF

' determine whether or not the retrieved row
'   has an instantiated object already in the
'   DBAwareCollection
        tempIndex = CollectionIndex( _
            Item:=CStr(RecordSet("ObjectID")))
        If tempIndex > 0 Then
            Set newChildObject = _
                pvtCollection(tempIndex)

' else, must instantiate a new object of the class
        Else

' have the Sample Object return an instantiated
'   copy of itself
            Set newChildObject = _
                pvtSampleObject.NewInstanceOfMyClass
            If Err = pvtReceiverDoesNotSupportThisMethod Then
                pvtErrorMessage "Object does not support the method 'NewInstanceOfMyClass'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
                GoTo pvtInstantiateObjectsFromRecordSet_Error
            End If
        End If

' have the new instantiated object copy populate
'   itself from this RecordSet row
        newChildObject _
            .InitializeFromRecordSet (RecordSet)
        If Err = pvtReceiverDoesNotSupportThisMethod Then
            pvtErrorMessage "Object does not support the method 'InitializeFromRecordSet'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
            GoTo pvtInstantiateObjectsFromRecordSet_Exit
        End If

' add the object to the collection
        tempCollection.Add _
            Item:=newChildObject, _
            Key:=CStr(newChildObject.ObjectID)

        RecordSet.MoveNext
    Wend

    GoTo pvtInstantiateObjectsFromRecordSet_Exit

pvtInstantiateObjectsFromRecordSet_Error:

pvtInstantiateObjectsFromRecordSet_Exit:
    Set pvtInstantiateObjectsFromRecordSet = _
        tempCollection
End Function

Private Function pvtName() As String
Attribute pvtName.VB_Description = "(Private) internal function"
    pvtName = "DBAwareCollection"
End Function

Private Function pvtCheckDatabase() As Integer
Attribute pvtCheckDatabase.VB_Description = "(Private) internal function"
' Determine whether or not the database has been
'   specified

    If pvtDatabase Is Nothing Then
        pvtErrorMessage pvtName & " cannot function without having been provided the name of the database.  Use the 'Database:=' parameter of the InstantiateFromDatabase method to specify the database."
        pvtCheckDatabase = False
        Exit Function
    End If

    pvtCheckDatabase = True
End Function

Private Sub pvtReceiveGeneralParameters(Optional ByVal Database As Variant, Optional ByVal SampleObject As Variant, Optional ByVal Parent As Variant, Optional ByVal WhereClause As Variant, Optional ByVal SQL As Variant, Optional ByVal OrderByClause As Variant, Optional CollectionEmulationMode As Variant)
Attribute pvtReceiveGeneralParameters.VB_Description = "(Private) internal function"
' Receive user-defined parameters

    If Not IsMissing(Database) Then
        Set pvtDatabase = Database
        pvtCollectionEmulationMode = False
    End If

    If Not IsMissing(SampleObject) Then
        Set pvtSampleObject = SampleObject
    End If

    If Not IsMissing(Parent) Then
        Set pvtParentObject = Parent
    End If

    If Not IsMissing(WhereClause) Then
        pvtWhereClause = WhereClause
        pvtCollectionEmulationMode = False
    End If

    If Not IsMissing(SQL) Then
        pvtSQLStatement = SQL
        pvtCollectionEmulationMode = False
    End If

    If Not IsMissing(OrderByClause) Then
        pvtOrderByClause = OrderByClause
        pvtCollectionEmulationMode = False
    End If

    If Not IsMissing(CollectionEmulationMode) Then
        pvtCollectionEmulationMode = CollectionEmulationMode
    End If

' pass-along signigicant values to DBAwareObjectLink
    pvtDBAwareObjectLink. _
        SetDatabaseParameters _
            Database:=Database, _
            DBAwareCollection:=Me, _
            CollectionEmulationMode:=pvtCollectionEmulationMode

    If Err = pvtReceiverDoesNotSupportThisMethod Then
        pvtErrorMessage "The DBAwareObjectLink Object is invalid (is missing method 'SetDatabaseParameters'.)" & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
    End If

End Sub


Public Function RefreshRecordSet() As RecordSet
Attribute RefreshRecordSet.VB_Description = "Refreshes the internally managed RecordSet which equates to the rows of the table which were used to instantiate the contained items.  Returns the RecordSet"
' Return the refreshed RecordSet after having refreshed its
'   contents by again using the same SQL-oriented
'   information used previously to generate the current
'   DBAwareCollection state.
' Note: users of the method "InstantiateFromRecordSet"
'   should not use this method

    If pvtRecordSetProvidedByUser Then
        pvtErrorMessage pvtName & " cannot execute the .RefreshRecordSet method because the current RecordSet was user-provided.  Only those RecordSets created by " & pvtName & " can be supported by the .RefreshRecordSet method."
        Set Refresh = Me
    End If

    Refresh

    Set RefreshRecordSet = pvtRecordSet
End Function

Public Sub SetDatabaseParameters(Optional ByVal Database As Variant, Optional ByVal SampleObject As Variant, Optional ByVal Parent As Variant, Optional ByVal WhereClause As Variant, Optional ByVal SQL As Variant, Optional ByVal OrderByClause As Variant, Optional ByVal CollectionEmulationMode As Variant)
Attribute SetDatabaseParameters.VB_Description = "Allows the user to set all of the database-related parameters in a single statement"
' Receive any database parameters the application
'   program wishes to set en masse

    pvtReceiveGeneralParameters _
        Database:=Database, _
        SampleObject:=SampleObject, _
        Parent:=Parent, _
        WhereClause:=WhereClause, _
        OrderByClause:=OrderByClause, _
        SQL:=SQL, _
        CollectionEmulationMode:=CollectionEmulationMode

End Sub

Public Function InstantiateFromRecordSet(Optional ByVal RecordSet As Variant, Optional ByVal Database As Variant, Optional ByVal SampleObject As Variant, Optional ByVal Parent As Variant, Optional ByVal WhereClause As Variant, Optional ByVal SQL As Variant, Optional ByVal OrderByClause As Variant) As DBAwareCollection
Attribute InstantiateFromRecordSet.VB_Description = "Sets the internally managed RecordSet"
' Sets a DBAwareCollection object which has been
'   instantiated as a collection of objects
'   represented by the contents of RecordSet
' Note: use of this method requires that the
'   caller maintain all of the necessary object
'   containment information, since DBAwareCollection
'   is unaware of the techniques used to derive the
'   contents of RecordSet

    On Local Error Resume Next

    pvtRecordSetProvidedByUser = True

' test SampleObject for Database-readiness
    If Not IsMissing(SampleObject) Then
        If (SampleObject.TableName = "" Or Err = 438) Then
            pvtCollectionEmulationMode = True
        End If
    End If

    pvtReceiveGeneralParameters _
        Database:=Database, _
        SampleObject:=SampleObject, _
        Parent:=Parent, _
        WhereClause:=WhereClause, _
        OrderByClause:=OrderByClause, _
        SQL:=SQL

' reference the RecordSet containing the desired rows
    Set pvtRecordSet = RecordSet

' create the objects from the contents of the RecordSet
    Set pvtCollection = _
        pvtInstantiateObjectsFromRecordSet( _
            RecordSet:=pvtRecordSet, _
            Collection:=pvtCollection)

    Set InstantiateFromRecordSet = Me
End Function

Public Function RecordSet() As RecordSet
' Returns a DataControl-ready RecordSet object
'   which pertains to the collection of objects
'   instantiated and contained within this
'   DBAwareCollection

    If pvtCollectionEmulationMode Then
        Set RecordSet = Nothing
        Exit Function
    End If

    Set RecordSet = pvtRecordSet
End Function
Public Function Refresh() As DBAwareCollection
Attribute Refresh.VB_Description = "Refreshes the internally managed RecordSet which equates to the rows of the table which were used to instantiate the contained items.  Returns the DBAwareCollection"
' Return a refreshed DBAwareCollection, using again
'   the same SQL-oriented information used previously
'   to generate the current DBAwareCollection state.
' Note: users of the method "InstantiateFromRecordSet"
'   should not use this method

    If pvtRecordSetProvidedByUser Then
'        pvtErrorMessage pvtName & " cannot execute the .Refresh method because the current RecordSet was user-provided.  Only those RecordSets created by " & pvtName & " can be supported by the .Refresh method."
        Set Refresh = Me
    End If

    If pvtCollectionEmulationMode Then
        Set Refresh = Me
    Else
        Set Refresh = InstantiateFromDatabase()
    End If
End Function

Public Function Remove(Optional ByVal Item As Variant, Optional ByVal Key As Variant, Optional ByVal NoDelete As Variant) As DBAwareCollection
Attribute Remove.VB_Description = "Removes the item from the DBAwareCollection and (if there are no more parents referencing the item) the associated table"
' Remove the Item from the DBAwareCollection and
'   return the DBAwareCollection

    Dim tempCountOfParentObjectLinksToItem As Long
    Dim tempSuppressDelete As Boolean

    On Local Error Resume Next

' bullet-proofing
    If IsMissing(Item) Then
        Remove = Me
        Exit Function
    End If
    tempSuppressDelete = False
    If Not IsMissing(NoDelete) Then
        tempSuppressDelete = NoDelete
    End If

' sever the link from pvtParentObject to Item
    If Not pvtCollectionEmulationMode Then
        pvtDBAwareObjectLink. _
            DeleteParentObjectLinksToItem _
                Child:=Item, _
                Parent:=pvtParentObject
        If Err = pvtReceiverDoesNotSupportThisMethod Then
            pvtErrorMessage "The DBAwareObjectLink Object is invalid (is missing method 'DeleteParentObjectLinksToItem'.)" & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
        End If
    End If

' if not operating in Collection-emulation mode
    If tempSuppressDelete = False And Not pvtCollectionEmulationMode Then

' count the number of Parent objects which currently
'   reference Item
        tempCountOfParentObjectLinksToItem = _
            pvtDBAwareObjectLink. _
                CountOfParentObjectLinksToItem( _
                   Child:=Item, _
                   Parent:=pvtParentObject)

' if none, then it's OK to actually remove Item
'   from the database
        If tempCountOfParentObjectLinksToItem = 0 Then

' verify that Item actually appears in the RecordSet
            If pvtFindItemInRecordSet(Item:=Item) Then

' delete Item from the database
'   and free the Item
                pvtDBDelete
            End If

' else, just Refresh the current RecordSet to
'   reflect the detached Item
        ElseIf Not pvtRecordSetProvidedByUser Then
            Refresh
        End If
    End If

' remove Item from the Collection
    pvtCollection.Remove _
        CollectionIndex(Item)

' fixed by Cary O. (01/16/1996)
    Set Item = Nothing

    Set Remove = Me
End Function


Public Function Replace(Optional ByVal Item As Variant, Optional ByVal ReplaceWith As Variant) As DBAwareCollection
Attribute Replace.VB_Description = "Replaces the item with the specified ReplaceWith item in the collection and in the associated table"
' Replace the specified Item with the ReplaceWith
'   Item, then return the DBAwareCollection

    Dim ItemIndex As Long

    On Local Error Resume Next

' bullet-proofing
    If IsMissing(Item) Or IsMissing(ReplaceWith) Then
        Set Replace = Me
        Exit Function
    End If

' there are two ways to handle a Replace:
'   1) replace the object in-place (non Collection-emulation mode, only),
'   2) replace the object with another
'
' process the replacement in-place:
    If Item.ObjectID = ReplaceWith.ObjectID And Not pvtCollectionEmulationMode Then

' position to the record to be updated (fix by Cary O., 01/16/1996)
'   or exit, if not found
        If Not pvtFindItemInRecordSet(Item:=Item) Then
            Set Replace = Me
            Exit Function
        End If

' initiate the RecordSet.Edit
        pvtRecordSet.Edit

' have Item initialize the RecordSet (fix by Cary O., 01/16/1996)
        ReplaceWith.InitializeRecordSet pvtRecordSet
        If Err = pvtReceiverDoesNotSupportThisMethod Then
            pvtErrorMessage "Object does not support the method 'InitializeRecordSet'." & vbCrLf & "Object cannot be supported by " & pvtName & " without this method."
        End If

' post the updates to the database
        pvtRecordSet.Update

' execute Me.Refresh
        Refresh

        Set Replace = Me
        Exit Function
    End If

' else, Item must be removed and replaced with ReplaceWith.
' save the position of Item in the Collection
    ItemIndex = CollectionIndex(Item)

' remove Item from the RecordSet and the Collection
    Remove _
        Item:=Item, _
        Key:=CStr(Item.ObjectID), _
        NoDelete:=True

' free Item
    Set Item = Nothing

' add the ReplaceWith item
    If ItemIndex > 0 Then
        Add _
            Item:=ReplaceWith, _
            Parent:=pvtParentObject, _
            After:=(ItemIndex - 1)
    Else
        Add _
            Item:=ReplaceWith, _
            Parent:=pvtParentObject
    End If

    Set Replace = Me
End Function

Private Function pvtFindItemInRecordSet(Optional ByVal Item As Variant) As Long
Attribute pvtFindItemInRecordSet.VB_Description = "(Private) internal function"

    Dim EachRecord As Variant
    Dim I As Long

    On Local Error Resume Next

    Err = 0

' check the current record first
    If Not pvtRecordSet.BOF And Not pvtRecordSet.EOF And pvtRecordSet.RecordCount > 0 Then
        If pvtRecordSet("ObjectID") = CStr(Item.ObjectID) Then
            pvtFindItemInRecordSet = True
            Exit Function
        End If
    End If

' else, .FindFirst
    pvtRecordSet.MoveFirst
    pvtRecordSet.FindNext "ObjectID = " & CStr(Item.ObjectID)

    If Err = 0 Then
        pvtFindItemInRecordSet = True
    Else
        pvtFindItemInRecordSet = False
    End If
End Function

Private Sub Class_Initialize()
    Set pvtCollection = New Collection
    Set pvtSampleObject = Nothing
    Set pvtParentObject = Nothing
    Set pvtDatabase = Nothing
    Set pvtRecordSet = Nothing

    pvtSQLStatement = ""
    pvtWhereClause = ""
    pvtDBHasBeenReferenced = False
    pvtCollectionEmulationMode = True
    pvtRecordSetProvidedByUser = False
    pvtHighestObjectID = 0
End Sub



Public Property Get WhereClause() As String
' Returns the current WhereClause value

    WhereClause = pvtWhereClause
End Property

Public Property Let WhereClause(WhereClause As String)
' Set the WhereClause to be used in future SQL Select
'   statements
' Note: this step is not necessarily required of the user

    pvtReceiveGeneralParameters _
        WhereClause:=WhereClause

    pvtCollectionEmulationMode = False
End Property

Public Property Get OrderByClause() As String
' Returns the current OrderByClause

    OrderByClause = pvtOrderByClause
End Property

Public Property Let OrderByClause(OrderByClause As String)
' Set the OrderByClause to be used in future SQL Select
'   statements
' Note: this step is not necessarily required of the user

    pvtReceiveGeneralParameters _
        OrderByClause:=OrderByClause

    pvtCollectionEmulationMode = False
End Property