ht206.frm

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

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   Caption         =   "Seek"
   ClientHeight    =   2520
   ClientLeft      =   2175
   ClientTop       =   2865
   ClientWidth     =   6300
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   2520
   ScaleWidth      =   6300
   Begin VB.TextBox txt 
      Height          =   285
      Index           =   3
      Left            =   5040
      TabIndex        =   5
      Top             =   900
      Width           =   915
   End
   Begin VB.CommandButton cmdMove 
      Caption         =   ">|"
      Height          =   375
      Index           =   3
      Left            =   5580
      TabIndex        =   11
      Top             =   1890
      Width           =   375
   End
   Begin VB.CommandButton cmdMove 
      Caption         =   ">"
      Height          =   375
      Index           =   2
      Left            =   5220
      TabIndex        =   10
      Top             =   1890
      Width           =   375
   End
   Begin VB.CommandButton cmdMove 
      Caption         =   "<"
      Height          =   375
      Index           =   1
      Left            =   4860
      TabIndex        =   9
      Top             =   1890
      Width           =   375
   End
   Begin VB.CommandButton cmdMove 
      Caption         =   "|<"
      Height          =   375
      Index           =   0
      Left            =   4500
      TabIndex        =   8
      Top             =   1890
      Width           =   375
   End
   Begin VB.TextBox txt 
      DataField       =   "ISBN"
      DataSource      =   "dtaTitles"
      Height          =   315
      Index           =   2
      Left            =   1890
      MaxLength       =   13
      TabIndex        =   7
      Top             =   1350
      Width           =   1635
   End
   Begin VB.TextBox txt 
      DataField       =   "Year Published"
      DataSource      =   "dtaTitles"
      Height          =   285
      Index           =   1
      Left            =   1890
      TabIndex        =   3
      Top             =   900
      Width           =   735
   End
   Begin VB.TextBox txt 
      DataField       =   "Title"
      DataSource      =   "dtaTitles"
      Height          =   555
      Index           =   0
      Left            =   1890
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   180
      Width           =   4095
   End
   Begin VB.Label Label4 
      Alignment       =   1  'Right Justify
      Caption         =   "&Publisher ID"
      Height          =   285
      Left            =   3690
      TabIndex        =   4
      Top             =   990
      Width           =   1185
   End
   Begin VB.Label Label3 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&ISBN:"
      Height          =   195
      Left            =   1200
      TabIndex        =   6
      Top             =   1440
      Width           =   510
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Year Published:"
      Height          =   195
      Left            =   360
      TabIndex        =   2
      Top             =   990
      Width           =   1350
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Title:"
      Height          =   195
      Left            =   1290
      TabIndex        =   0
      Top             =   180
      Width           =   450
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuData 
      Caption         =   "&Data"
      Begin VB.Menu mnuDataSaveRecord 
         Caption         =   "&Save Record"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuDataIndex 
         Caption         =   "&Index"
         Begin VB.Menu mnuDataIndexName 
            Caption         =   "&ISBN"
            Index           =   0
         End
         Begin VB.Menu mnuDataIndexName 
            Caption         =   "&Title"
            Index           =   1
         End
      End
      Begin VB.Menu mnuDataSeek 
         Caption         =   "S&eek"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' CTitles object
Private mclsTitles As CTitles

' These constants are used for the various control arrays
' command button constants
Const cmdMoveFirst = 0
Const cmdMovePrevious = 1
Const cmdMoveNext = 2
Const cmdMoveLast = 3
' text box index constants
Const txtTitle = 0
Const txtYearPublished = 1
Const txtISBN = 2
Const txtPubID = 3
' index constants
Const idxISBN = 0
Const idxTitle = 1

' refresh flag
Private mblnInRefresh As Boolean

Private Sub Form_Load()
' create the mclsTitles object and display the first record
On Error GoTo ProcError

    Dim strDBName As String

    Screen.MousePointer = vbHourglass

    ' create the CTitles object
    Set mclsTitles = New CTitles
    
    ' fetch and display the current record
    GetData

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    ' An error was generated by Visual Basic or CTitles.
    ' Display the error message and terminate gracefully.
    MsgBox Err.Description, vbExclamation
    Unload Me
    Resume ProcExit

End Sub

Private Sub Form_QueryUnload( _
  Cancel As Integer, _
  UnloadMode As Integer)
On Error GoTo ProcError

    Screen.MousePointer = vbHourglass

    ' save the current record
    mclsTitles.SaveRecord
    
ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    ' an error here means the record won't be saved
    ' let the user decide what to do
    Dim strMsg As String

    strMsg = "The following error occured while attempting to save:"
    strMsg = strMsg & vbCrLf & Err.Description & vbCrLf
    strMsg = strMsg & "If you continue the current operation, changes "
    strMsg = strMsg & "to your data will be lost." & vbCrLf
    strMsg = strMsg & "Do you want to continue anyway?"

    If MsgBox(strMsg, vbQuestion Or vbYesNo Or vbDefaultButton2) = vbNo Then
        Cancel = True
    End If
    Resume ProcExit

End Sub

Private Sub GetData()
' display the current record

    ' set the mblnInRefresh flag so that the txt_Change event
    ' doesn't write the property values again
    mblnInRefresh = True
    
    ' assign the values to the controls from the properties
    txt(txtTitle).Text = mclsTitles.Title
    txt(txtYearPublished).Text = mclsTitles.YearPublished
    txt(txtISBN).Text = mclsTitles.ISBN
    txt(txtPubID).Text = mclsTitles.PubID
    
    ' clear the refresh flag
    mblnInRefresh = False

End Sub

Private Sub cmdMove_Click(Index As Integer)
' move to the desired record, saving first
On Error GoTo ProcError

    Screen.MousePointer = vbHourglass
    
    ' save the record
    mclsTitles.SaveRecord
    
    ' move to the indicated record
    Select Case Index
        Case cmdMoveFirst
            mclsTitles.Move FirstRecord
        Case cmdMoveLast
            mclsTitles.Move LastRecord
        Case cmdMoveNext
            mclsTitles.Move NextRecord
        Case cmdMovePrevious
            mclsTitles.Move PreviousRecord
    End Select
    
    ' refresh display
    GetData
    
ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub
    
ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub

Private Sub txt_Change(Index As Integer)
' update property values if required
On Error GoTo ProcError

    Dim strValue As String
    
    Screen.MousePointer = vbHourglass
    
    ' fetch the value from the control
    strValue = txt(Index).Text

    ' check first to see if we're in a GetData call
    ' assigning the property values while refreshing
    ' will reset the dirty flag again so the data will
    ' never appear to have been saved
    If Not mblnInRefresh Then
        ' update the clsTitles properties
        Select Case Index
            Case txtTitle
                mclsTitles.Title = strValue
            Case txtYearPublished
                mclsTitles.YearPublished = strValue
            Case txtISBN
                mclsTitles.ISBN = strValue
            Case txtPubID
                mclsTitles.PubID = strValue
        End Select
    End If

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub
    
ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub

Private Sub mnuFileExit_Click()

    ' shut down
    ' work is handled by the Query_Unload event
    Unload Me
    
End Sub

Private Sub mnuData_Click()
' set enabled/disabled flags for menu commands
On Error GoTo ProcError

    Screen.MousePointer = vbHourglass

    ' save enabled only when dirty
    mnuDataSaveRecord.Enabled = mclsTitles.IsDirty

    ' seek enabled only if index is set
    If Len(mclsTitles.IndexName) Then
        mnuDataSeek.Enabled = True
    Else
        mnuDataSeek.Enabled = False
    End If

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub

Private Sub mnuDataSaveRecord_Click()
On Error GoTo ProcError

    Screen.MousePointer = vbHourglass

    ' save it
    mclsTitles.SaveRecord
    
    ' refresh display
    GetData

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub

Private Sub mnuDataIndexName_Click(Index As Integer)
' set the current index
On Error GoTo ProcError

    Screen.MousePointer = vbHourglass
    
    ' set the index
    Select Case Index
        Case idxISBN
            ' assign the index
            mclsTitles.Index = IndexISBN
            ' setup menu check marks
            mnuDataIndexName(idxTitle).Checked = False
            mnuDataIndexName(idxISBN).Checked = True
        Case idxTitle
            ' assign the index
            mclsTitles.Index = IndexTitle
            ' setup menu check marks
            mnuDataIndexName(idxTitle).Checked = True
            mnuDataIndexName(idxISBN).Checked = False
    End Select

    ' refesh display
    GetData

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub

Private Sub mnuDataSeek_Click()
' seek a record
On Error GoTo ProcError

    Dim strMsg As String
    Dim strResult As String
        
    Screen.MousePointer = vbHourglass
    
    ' prompt for a value
    strMsg = "Enter a value to search for:"
    strResult = InputBox$(strMsg)
    
    ' seek for the record
    mclsTitles.SeekRecord strResult
    
    ' refresh display
    GetData

ProcExit:
    Screen.MousePointer = vbDefault
    Exit Sub

ProcError:
    MsgBox Err.Description, vbExclamation
    Resume ProcExit

End Sub