ht204.cls

《VB6数据库开发指南》所有的例程的源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CTitles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' The CTitles class provides a light wrapper
' around the database and record for the
' Titles table in the Biblio database

' Note: It's up to the client to save

' Database and recordset objects
Private mdb As Database
Private mrs As Recordset

' Flags
' dirty flag
Private mblnIsDirty As Boolean
' new record flag
Private mblnIsNew As Boolean

' Fields
' title
Private mstrTitle As String
' year - note use of string for
' assignment to text box
Private mstrYearPublished As String
' ISBN number
Private mstrISBN As String
' PubID - also a string
Private mstrPubID As String

' Move method constants
Public Enum CTitlesMove
    FirstRecord = 1
    LastRecord = 2
    NextRecord = 3
    PreviousRecord = 4
End Enum

' Error constants
' Note: RaiseClassError method provides the strings
' because you cannot assign a string to an Enum
Public Enum CTitlesError
    ErrInvalidMoveType = vbObjectError + 1000 + 11
    ErrNoRecords = vbObjectError + 1000 + 12
End Enum

Private Sub Class_Initialize()

    ' open the database and recordset
    
    Dim strDBName As String
    
    ' Get the database name and open the database.
    ' BiblioPath is a function in READINI.BAS
    strDBName = BiblioPath()
    Set mdb = DBEngine.Workspaces(0).OpenDatabase(strDBName)
        
    ' Open the recordset.
    Set mrs = mdb.OpenRecordset( _
        "Titles", dbOpenDynaset, dbSeeChanges, dbOptimistic)
    
    ' Raise an error if there is no data
    If mrs.BOF Then
        RaiseClassError ErrNoRecords
    End If
    
    ' fetch the first record to the properties
    GetCurrentRecord

End Sub
Private Sub Class_Terminate()
' cleanup - note that since a Class_Terminate error
' is fatal to the app, this proc simply traps and
' ignores any shutdown errors
' that's not a great solution, but there's not much
' else that can be done at this point
' in a production app, it might be helpful to log
' these errors

    ' close and release the recordset object
    mrs.Close
    Set mrs = Nothing
    ' close and release the database object
    mdb.Close
    Set mdb = Nothing

End Sub

Private Sub RaiseClassError(lngErrorNumber As CTitlesError)
' Note: DAO errors are passed out as-is

    Dim strDescription As String
    Dim strSource As String
    
    ' assign the description for the error
    Select Case lngErrorNumber
        Case ErrInvalidMoveType
            strDescription = "Invalid move operation."
        Case ErrNoRecords
            strDescription = _
                "There are no records in the Titles table."
        Case Else
            ' If this executes, it's a coding error in
            ' the class module, but having the case is
            ' useful for debugging.
            strDescription = "There is no message for this error."
    End Select
    
    ' build the Source property for the error
    strSource = App.EXEName & ".CTitles"
    
    ' raise it
    Err.Raise lngErrorNumber, strSource, strDescription

End Sub

Private Sub GetCurrentRecord()
' Get current values from the recordset

    ' a zero length string is appended to
    ' each variable to avoid the Invalid use of Null
    ' error if a field is null
    ' although current rules don't allow nulls, there
    ' may be legacy data that doesn't conform to
    ' existing rules
    mstrISBN = mrs![ISBN] & ""
    mstrTitle = mrs![Title] & ""
    mstrYearPublished = mrs![Year Published] & ""
    mstrPubID = mrs![PubID] & ""

End Sub

Private Sub UpdateRecord()
' DAO Edit/Update
On Error GoTo ProcError

    ' inform DAO we will edit
    mrs.Edit
    mrs![ISBN] = mstrISBN
    mrs![Title] = mstrTitle
    mrs![Year Published] = mstrYearPublished
    mrs![PubID] = mstrPubID
    ' commit changes
    mrs.Update
    ' clear dirty flag
    mblnIsDirty = False

    Exit Sub

ProcError:
    ' clear the values that were assigned
    ' and cancel the edit method by
    ' executing a moveprevious/movenext
    mrs.MovePrevious
    mrs.MoveNext
    ' raise the error again
    Err.Raise Err.Number, Err.Source, Err.Description, _
        Err.HelpFile, Err.HelpContext

End Sub

Public Property Get Title() As String
    
    Title = mstrTitle

End Property
Public Property Let Title(strTitle As String)

    mstrTitle = strTitle
    ' set the dirty flag
    mblnIsDirty = True

End Property
Public Property Get YearPublished() As String

    YearPublished = mstrYearPublished
    
End Property
Public Property Let YearPublished(strYearPublished As String)

    mstrYearPublished = strYearPublished
    ' set the dirty flag
    mblnIsDirty = True

End Property
Public Property Get ISBN() As String

    ISBN = mstrISBN

End Property
Public Property Let ISBN(strISBN As String)

    mstrISBN = strISBN
    ' set the dirty flag
    mblnIsDirty = True

End Property
Public Property Get PubID() As String

    PubID = mstrPubID
    
End Property
Public Property Let PubID(strPubID As String)

    mstrPubID = strPubID
    ' set the dirty flag
    mblnIsDirty = True
    
End Property

Public Property Get IsDirty() As Boolean
' pass out the dirty flag

    IsDirty = mblnIsDirty
    
End Property

Public Sub Move(lngMoveType As CTitlesMove)
' Move and refresh properties

    Select Case lngMoveType
        Case FirstRecord
            mrs.MoveFirst
        Case LastRecord
            mrs.MoveLast
        Case NextRecord
            mrs.MoveNext
            ' check for EOF
            If mrs.EOF Then
                mrs.MoveLast
            End If
        Case PreviousRecord
            mrs.MovePrevious
            ' check for BOF
            If mrs.BOF Then
                mrs.MoveFirst
            End If
        Case Else
            ' bad parameter, raise an error
            RaiseClassError ErrInvalidMoveType
    End Select
    
    GetCurrentRecord

End Sub

Public Sub SaveRecord()
' save current changes

    ' test dirty flag
    If mblnIsDirty Then
        ' test new flag
        If mblnIsNew Then
            ' add it
            AddNewRecord
        Else
            ' update it
            UpdateRecord
        End If
    Else
        ' record is already clean
    End If

End Sub

Private Sub AddNewRecord()
' DAO AddNew/Update

    ' inform DAO we are going to insert
    mrs.AddNew
    ' write the current values
    mrs![ISBN] = mstrISBN
    mrs![Title] = mstrTitle
    mrs![Year Published] = mstrYearPublished
    mrs![PubID] = mstrPubID
    ' update the record
    mrs.Update
    ' return to the new record
    mrs.Bookmark = mrs.LastModified
    ' clear new flag
    mblnIsNew = False
    ' clear dirty flag
    mblnIsDirty = False

End Sub

Public Sub DeleteRecord()
' DAO delete

    ' delete the record
    mrs.Delete
    ' clear new and dirty flags
    mblnIsDirty = False
    mblnIsNew = False

    ' reposition to a valid record
    mrs.MovePrevious
    ' check for BOF
    If mrs.BOF Then
        ' could be empty, check EOF
        If Not mrs.EOF Then
            mrs.MoveFirst
        Else
            ' empty recordset, raise error
            ' the client must decide how to
            ' handle this situation
            RaiseClassError ErrNoRecords
        End If
    End If

    GetCurrentRecord

End Sub

Public Sub NewRecord()
' clear the current values for an insert
' NOTE: the flags work so that if a new
' record is added but not changed, you
' can move off of it or close with no
' prompt to save

    ' assign zero-length strings to the properties
    mstrISBN = ""
    mstrTitle = ""
    mstrYearPublished = ""
    mstrPubID = ""
    ' set the new flag
    mblnIsNew = True

End Sub

Public Property Get IsNew() As Boolean
' pass out the new flag

    IsNew = mblnIsNew

End Property