frmtracker.frm

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

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTracker 
   Caption         =   "Tracker"
   ClientHeight    =   2640
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7110
   LinkTopic       =   "Form1"
   ScaleHeight     =   2640
   ScaleWidth      =   7110
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdAddRecord 
      Caption         =   "&Add Record"
      Height          =   435
      Left            =   5760
      TabIndex        =   2
      Top             =   780
      Width           =   1275
   End
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "&Close"
      Default         =   -1  'True
      Height          =   435
      Left            =   5760
      TabIndex        =   1
      Top             =   180
      Width           =   1275
   End
   Begin ComctlLib.ListView lstCustomers 
      Height          =   2355
      Left            =   120
      TabIndex        =   0
      Top             =   180
      Width           =   5535
      _ExtentX        =   9763
      _ExtentY        =   4154
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      HideColumnHeaders=   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   3
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "Order Number"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   1
         Text            =   "User Name"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   2
         Text            =   "Last Modified"
         Object.Width           =   2540
      EndProperty
      _Items          =   "frmTracker.frx":0000
   End
End
Attribute VB_Name = "frmTracker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' form level object variables used to store database and recordset objects
Private db As Database
Private rs As Recordset


Private Sub Form_Load()

' if there is an error goto the code labeled by ERR_Form_Load
On Error GoTo ERR_Form_Load:

    ' local constant declaration for invalid user name or password error
    Const ERR_INVALID_INFORMATION = 3029
    
    Dim sUserName As String
    Dim sPassword As String
    Dim sDBName As String
    
    ' get user name
    sUserName = InputBox("Enter user name.", "LOGON")
    
    ' get user password
    sPassword = InputBox("Enter password.", "LOGON")
    
    With DBEngine
        
        ' set system database path and name
        .SystemDB = GetWorkgroupDatabase
        
        ' set default passwords
        .DefaultUser = sUserName
        .DefaultPassword = sPassword
        
        ' retrieve database path and name from ReadINI module
        sDBName = DBPath
        
        ' open database with given user and password
        Set db = .Workspaces(0).OpenDatabase(sDBName)
    
    End With
    
    ' populate the list view control
    PopulateListView

Exit Sub

ERR_Form_Load:

    Dim sMessage As String
    
    With Err
    
        Select Case .Number
        
            ' invalid user or password
            Case ERR_INVALID_INFORMATION:
                sMessage = "Invalid user name or password."
                
            ' unexpected error, notify the user
            Case Else
                sMessage = "ERROR #" & .Number & ": " & .Description
                
        End Select
        
    End With
    
    ' display the message for the user
    MsgBox sMessage, vbExclamation, "ERROR"
    
    ' end the application
    cmdClose_Click
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' close the recordset and database
    Set rs = Nothing
    Set db = Nothing
        
End Sub

Private Sub cmdAddRecord_Click()

' if an error occurs, call the ERR_cmdAddRecord code located at the  end of
' this procedure
On Error GoTo ERR_cmdAddRecord:

    Dim sMessage As String
    Dim lPrimaryKey As Long
    
    ' used to populate fields in Customer table
    ' this is necessary because most of the fields belong to indexes making
    ' them required fields
    Const DUMMY_INFO = "<>"
    
    ' retrieve a unique key from the GetPrimaryKey routine
    lPrimaryKey = GetPrimaryKey
    
    With rs
    
        ' add a new record
        .AddNew
        
        ' fill in the required fields
        .Fields("Customer Number") = lPrimaryKey
        .Fields("Customer Name") = DUMMY_INFO
        .Fields("Street Address") = DUMMY_INFO
        .Fields("City") = DUMMY_INFO
        .Fields("State") = DUMMY_INFO
        .Fields("Zip Code") = DUMMY_INFO
        
        ' set the user name, date, and time of new record to track users
        .Fields("User Last Modified") = DBEngine.Workspaces(0).UserName
        .Fields("DateTime Last Modified") = Now
        
        ' make saves (if an error will occur, it will be here)
        .Update
        
    End With
    
    PopulateListView
    
    ' if we got this far, add new record was successfull
    sMessage = "Record added successfully!"
    MsgBox sMessage, vbInformation, "ADD RECORD"
        
Exit Sub

ERR_cmdAddRecord:

    ' display error for user
    With Err
        MsgBox "ERROR #" & .Number & ": " & .Description, vbExclamation, _
               "ERROR"
    End With
    
End Sub

Private Sub cmdClose_Click()

    ' end the application
    Unload Me
    
End Sub

Private Function GetPrimaryKey()

    ' return a unique primary key based on the Customer Number field
    With rs
    
        ' if there are records in the table already, find the last one and
        ' add one to the Customer Number as a unique Primary Key, otherwise
        ' there are no records in the table so return 1 for the first new
        ' record to be added
        If (Not (.EOF And .BOF)) Then
            
            .MoveLast
            
            GetPrimaryKey = .Fields("Customer Number") + 1
        
        Else
            
            GetPrimaryKey = 1
        
        End If
        
    End With
    
End Function

Private Sub PopulateListView()

    Dim oItem As ListItem
    
    ' show headers of list view and clear the contents of the ListItems
    ' collection
    With lstCustomers
        .HideColumnHeaders = False
        .ListItems.Clear
    End With
    
    ' repopulate the recordset
    Set rs = db.OpenRecordset("Customers", dbOpenTable)
    
    With rs
        
        ' order the records by the primary key
        .Index = "PrimaryKey"
    
        ' add all records to the list view
        While (Not rs.EOF)
        
            Set oItem = lstCustomers.ListItems.Add(, , .Fields("Customer Number"))
            
            oItem.SubItems(1) = "" & .Fields("User Last Modified")
            oItem.SubItems(2) = "" & .Fields("DateTime Last Modified")
            
            .MoveNext
        
        Wend
        
    End With

End Sub