ht206.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
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

' 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
    ErrRecordNotFound = vbObjectError + 1000 + 10
    ErrInvalidMoveType = vbObjectError + 1000 + 11
    ErrNoRecords = vbObjectError + 1000 + 12
    ErrInvalidIndex = vbObjectError + 1000 + 13
End Enum

' Index constants
Public Enum CTitlesIndex
    IndexISBN = 0
    IndexTitle = 1
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", dbOpenTable, 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 procedures

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 ErrRecordNotFound
            strDescription = "The record was not found."
        Case ErrInvalidMoveType
            strDescription = "Invalid move operation."
        Case ErrNoRecords
            strDescription = _
                "There are no records in the Titles table."
        Case ErrInvalidIndex
            strDescription = "Invalid Index Name."
        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
        ' update it
        UpdateRecord
    Else
        ' record is already clean
    End If

End Sub

Public Property Get IndexName() As String

    IndexName = mrs.Index

End Property

Public Property Let Index(lngIndex As CTitlesIndex)
' unlike the field values, this is validated when assigned

    Dim vntBookmark As Variant

    ' save a bookmark
    vntBookmark = mrs.Bookmark
    ' assign the index
    Select Case lngIndex
        Case IndexISBN
            mrs.Index = "PrimaryKey"
        Case IndexTitle
            mrs.Index = "Title"
        Case Else
            ' invalid, raise an error
            RaiseClassError ErrInvalidIndex
    End Select
    
    ' return to old record
    mrs.Bookmark = vntBookmark

End Property

Public Sub SeekRecord(strValue As String)
' seek to the indicated record based on the current index

    Dim vntBookmark As Variant
    
    ' mark the current record
    vntBookmark = mrs.Bookmark
    ' seek, the first operator is the comparison,
    ' the following represent the field(s) in the index
    mrs.Seek "=", strValue
    ' check for match
    If Not mrs.NoMatch Then
        ' found it, now fetch it
        GetCurrentRecord
    Else
        ' not found, return to prior location
        mrs.Bookmark = vntBookmark
        ' raise the not found error
        RaiseClassError ErrRecordNotFound
    End If

End Sub