frmtablelocker.frm

大量优秀的vb编程

VERSION 5.00
Begin VB.Form frmTableLocker 
   Caption         =   "表的锁定"
   ClientHeight    =   1932
   ClientLeft      =   60
   ClientTop       =   348
   ClientWidth     =   5028
   LinkTopic       =   "Form1"
   ScaleHeight     =   1932
   ScaleWidth      =   5028
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdCloseTable 
      Caption         =   "关闭表"
      Height          =   375
      Left            =   2520
      TabIndex        =   2
      Top             =   1440
      Width           =   1095
   End
   Begin VB.CommandButton cmdAddRecord 
      Caption         =   "添加记录"
      Height          =   375
      Left            =   1320
      TabIndex        =   1
      Top             =   1440
      Width           =   1095
   End
   Begin VB.CommandButton cmdOpenTable 
      Caption         =   "打开表"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   1440
      Width           =   1095
   End
   Begin VB.CommandButton cmdExit 
      Cancel          =   -1  'True
      Caption         =   "退出程序"
      Default         =   -1  'True
      Height          =   375
      Left            =   3720
      TabIndex        =   3
      Top             =   1440
      Width           =   1215
   End
   Begin VB.Frame fraTableSharing 
      Caption         =   "表的读写权限"
      Height          =   1215
      Left            =   120
      TabIndex        =   6
      Top             =   120
      Width           =   4092
      Begin VB.CheckBox chkDenyWrite 
         Caption         =   "拒绝其他用户写表"
         Height          =   255
         Left            =   360
         TabIndex        =   5
         Top             =   720
         Width           =   3612
      End
      Begin VB.CheckBox chkDenyRead 
         Caption         =   "拒绝其他用户读表"
         Height          =   255
         Left            =   360
         TabIndex        =   4
         Top             =   360
         Width           =   3612
      End
   End
End
Attribute VB_Name = "frmTableLocker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' form level object variables used to access the database and recordset
' objects used throughout this project
Private db As Database
Private rs As Recordset


Private Sub chkDenyRead_Click()

End Sub

Private Sub chkDenyWrite_Click()

End Sub

Private Sub Form_Initialize()
    
    ' initialize the form controls to show that the table is closed upon
    ' start up of project
    cmdCloseTable_Click

End Sub

Private Sub Form_Load()

    Dim sDBName As String
    
    ' obtain the name and path of the table to be used in this project from
    ' the ReadINI module
    sDBName = DBPath
    
    ' open the database
    ' by not specifying an exclusive mode, the database is opened in shared
    ' mode
    Set db = DBEngine.Workspaces(0).OpenDatabase(sDBName)

End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    ' close the database and recordset objects by setting them to nothing
    Set db = Nothing
    Set rs = Nothing

End Sub

Private Sub cmdOpenTable_Click()
    
' if an error occurs, call the ERR_cmdOpenTable_Click code located at the
' end of this procedure
On Error GoTo ERR_cmdOpenTable_Click:

    ' local variable used to store permissions
    Dim nAccessValue As Integer
    
    ' set the mouse pointer to an hourglass because on some machines, this
    ' could take a few seconds
    Screen.MousePointer = vbHourglass
    
    ' default the permissions to nothing (all access okay)
    nAccessValue = 0
    
    ' apply the proper permissions that were restricted by the user
    If (chkDenyRead) Then nAccessValue = nAccessValue + dbDenyRead
    If (chkDenyWrite) Then nAccessValue = nAccessValue + dbDenyWrite
    
    ' open the table using the permission variable
    Set rs = db.OpenRecordset("Customers", dbOpenTable, nAccessValue)
    
    ' set the index to the PrimaryKey used later in GetPrimaryKey
    rs.Index = "PrimaryKey"
    
    ' release any locks that may be on the table, and process any data that
    ' is waiting to be completed
    DBEngine.Idle dbRefreshCache

    ' allow the correct status of the enabled property of the frmTableLocker
    ' controls
    cmdOpenTable.Enabled = False
    chkDenyRead.Enabled = False
    chkDenyWrite.Enabled = False
    cmdAddRecord.Enabled = True
    cmdCloseTable.Enabled = True
    
    ' set the mousepointer back to its default because we are now finished
    Screen.MousePointer = vbDefault

Exit Sub

ERR_cmdOpenTable_Click:

    ' an error has occured, therefore change the mousepointer back to an
    ' hourglass
    Screen.MousePointer = vbDefault
    
    ' call the TableError function, passing the error object describing the
    ' error that has occured
    ' if a value of True is returned, we are going to try opening the table
    ' again with read only access
    If (TableError(Err)) Then
        chkDenyRead = False
        chkDenyWrite = False
        nAccessValue = dbReadOnly
        Resume
    End If
    
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 lPrimaryKey As Long
    Dim sMessage As String
    
    ' 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
        
        ' make saves (if an error will occur, it will be here)
        .Update
    
    End With
    
    ' if we got this far, add new record was successfull
    sMessage = "Record added successfully!"
    MsgBox sMessage, vbInformation, "ADD RECORD"
        
Exit Sub

ERR_cmdAddRecord:

    ' an error has occurred, call the TableError function and pass the
    ' Err object describing the error
    TableError Err
    
End Sub

Private Sub cmdCloseTable_Click()

    ' set the rs object variable to nothing, closing the recordset
    Set rs = Nothing
    
    ' properly display the controls on the frmTableLocker form
    chkDenyRead.Enabled = True
    chkDenyWrite.Enabled = True
    cmdOpenTable.Enabled = True
    cmdAddRecord.Enabled = False
    cmdCloseTable.Enabled = False

End Sub

Private Sub cmdExit_Click()
    
    ' using Unload Me will call Form_Unload where the form level database
    ' and recordset object variables will be set to nothing
    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 Function TableError(oErr As ErrObject) As Boolean

    Dim sMessage As String
    Dim nResponse As Integer
        
    ' these are the constant values used to represent the four errors that
    ' we are going to trap in this code
    
    Const TB_OPEN = 3262            ' database already open in shared mode
    Const TB_IN_USE = 3261          ' database already open exclusively
    Const TB_READ_ONLY = 3027       ' can't save, read only
    Const TB_LOCKED = 3186          ' table is locked, cannot update
    
    ' defualt the return value of the function to false which will indicate
    ' that we do not want to try again
    TableError = False
    
    With oErr
        
        ' select the appropriate code depending upon the error number
        Select Case .Number
            
            ' the table couldn't be opened using the permissions requested
            ' aske the user if they would like to open it in read only mode
            Case TB_OPEN, TB_IN_USE:
                
                sMessage = "There was an error opening the table.  " _
                         & "Would you like to try read only mode?"
                
                nResponse = MsgBox(sMessage, vbYesNo + vbQuestion, "ERROR")
                
                If (nResponse = vbYes) Then TableError = True
                
                Exit Function
                
            ' the table is read only and you cannot add a new record
            Case TB_READ_ONLY:
                
                sMessage = "You cannot add a record because the " _
                         & "database is currently opened with read " _
                         & "only status."
                         
            ' the table is locked and you cannot add a new record
            Case TB_LOCKED:
                
                sMessage = "You cannot add a record because the " _
                         & "database is currently locked by another " _
                         & "user."
                
            ' unexpected error: display the error number and description
            ' for the user
            Case Else
            
                sMessage = "Error #" & .Number & ": " & .Description
        
        End Select
    
    End With
    
    ' display the message for the user
    MsgBox sMessage, vbExclamation, "TABLE ERROR"
    
    ' ensure that the database is closed because of the error, and properly
    ' set all the command button enabled properties as well as the status
    ' label
    cmdCloseTable_Click

End Function