frmmain.frm

功能强大的 DBF 数据库操作 dll,可以让 VB 和 POWERBASIC 调用

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmMain 
   Caption         =   "Cheetah MultiUser Test"
   ClientHeight    =   3645
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   6180
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3645
   ScaleWidth      =   6180
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton cmdRefresh 
      Caption         =   "Refresh Record Count"
      Height          =   300
      Left            =   3528
      TabIndex        =   10
      Top             =   2112
      Width           =   2136
   End
   Begin VB.CommandButton cmdClose 
      Caption         =   "Close"
      Height          =   384
      Left            =   3108
      TabIndex        =   8
      Top             =   216
      Width           =   1224
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   276
      Top             =   1548
      _ExtentX        =   688
      _ExtentY        =   688
      _Version        =   393216
   End
   Begin VB.CommandButton cmdOpen 
      Caption         =   "Open"
      Height          =   384
      Left            =   336
      TabIndex        =   6
      Top             =   756
      Width           =   1224
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "Quit"
      Height          =   384
      Left            =   3108
      TabIndex        =   5
      Top             =   756
      Width           =   1224
   End
   Begin VB.CommandButton cmdDelete 
      Caption         =   "Delete"
      Height          =   384
      Left            =   1728
      TabIndex        =   4
      Top             =   1848
      Width           =   1224
   End
   Begin VB.CommandButton cmdEdit 
      Caption         =   "Edit"
      Height          =   384
      Left            =   1728
      TabIndex        =   3
      Top             =   1308
      Width           =   1224
   End
   Begin VB.CommandButton cmdReadAll 
      Caption         =   "Read All"
      Height          =   384
      Left            =   1728
      TabIndex        =   2
      Top             =   756
      Width           =   1224
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "Add"
      Height          =   384
      Left            =   1728
      TabIndex        =   1
      Top             =   216
      Width           =   1224
   End
   Begin VB.CommandButton cmdCreate 
      Caption         =   "Create"
      Height          =   384
      Left            =   336
      TabIndex        =   0
      Top             =   216
      Width           =   1224
   End
   Begin VB.Label lblNumRecords 
      Caption         =   "Number of Records:"
      Height          =   276
      Left            =   3540
      TabIndex        =   9
      Top             =   1848
      Width           =   2400
   End
   Begin VB.Label lblMessage 
      Caption         =   "Messages"
      Height          =   1008
      Left            =   300
      TabIndex        =   7
      Top             =   2496
      Width           =   5676
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'variable to hold Cheetah database handle & name
Public gDBFhandle As Long
Public gDatabaseName As String




Private Sub cmdAdd_Click()

    Load frmAddEdit
    With frmAddEdit
       .AddRecord
       .Show
    End With
    
End Sub

Private Sub cmdClose_Click()

    'if the database is open then close it
    If gDBFhandle > 0 Then
       Call xdbClose(gDBFhandle)
       lblMessage.Caption = "Database Closed. " & gDatabaseName
       Call SetCommandButtons(False)
    End If

End Sub

Private Sub cmdCreate_Click()
    
    On Error GoTo Cancel_Create
    
    'ask for a database name to create
    With CommonDialog1
       .DefaultExt = "dbf"
       .CancelError = True
       .Flags = cdlOFNOverwritePrompt
       .DialogTitle = "Create Database"
       .FileName = "test.dbf"
       .ShowSave
    End With
    
    If CommonDialog1.FileName = "" Then
       Exit Sub
    Else
       gDatabaseName = CommonDialog1.FileName
       Call SetCommandButtons(True)
    End If
    
    'create a new Cheetah database
    Dim fd(1 To 3) As String
    
    fd(1) = "ACCTNUM, C, 5, 0"
    fd(2) = "ACCTNAME, C, 40, 0"
    fd(3) = "NOTES, M, 10, 0"
    
    Call xdbCreate(gDatabaseName, fd())
    
    gDBFhandle = xdbOpen(gDatabaseName)
    
    lblNumRecords.Caption = "Number of Records:" & Str$(xdbRecordCount(gDBFhandle))
    lblMessage.Caption = "Database Created and Opened. " & gDatabaseName
    
    Exit Sub
    
Cancel_Create:
    Exit Sub
    
End Sub



Private Sub cmdDelete_Click()

    RecordNumber = InputBox("Enter Record Number to Delete:", "Delete Record")
    
    'determine if the record exists.
    If RecordNumber > 0 And RecordNumber <= xdbRecordCount(gDBFhandle) Then
       Call xdbDeleteRecord(gDBFhandle, RecordNumber)
       
       'check to see if the Delete failed. A delete will fail if the record
       'to be deleted is currently being edited by another program.
       If xdbError = RECORD_BUSY Then
            Call xdbFailedLockInfo(gDBFhandle, Reason$, Username$, Workstation$, LockDate$, LockTime$)
            msg$ = "Record " & Str$(RecordNumber) & " is currently in use by " & Username$ & " " & _
                    Workstation$ & " at " & LockDate$ & " " & LockTime$ & vbCrLf & "Reason: " & Reason$
                    
            MsgBox msg$
            
            'IMPORTANT - reset the error code so Cheetah will not choke on
            'future functions.
            Call xdbResetError
       
       Else
            'the deleted database records remain in the database until the database
            'is packed. The record is simply marked with an "*" in the first field.
            Call xdbPack(gDBFhandle)
            
            lblMessage.Caption = "Record" & Str$(RecordNumber) & " deleted and database packed."
            lblNumRecords.Caption = "Number of Records:" & Str$(xdbRecordCount(gDBFhandle))
      End If
    End If

End Sub

Private Sub cmdEdit_Click()

    Load frmAddEdit
    With frmAddEdit
       .EditRecord
       .Show
    End With

End Sub


Private Sub cmdOpen_Click()

    'open the database
    On Error GoTo Cancel_Open
    
    'ask for a database name to create
    With CommonDialog1
       .DefaultExt = "dbf"
       .CancelError = True
       .Flags = cdlOFNFileMustExist
       .DialogTitle = "Open Database"
       .FileName = "test.dbf"
       .ShowOpen
    End With
    
    If CommonDialog1.FileName = "" Then
       Exit Sub
    Else
       gDatabaseName = CommonDialog1.FileName
       Call SetCommandButtons(True)
    End If
    
    gDBFhandle = xdbOpen(gDatabaseName)
    
    lblMessage.Caption = "Database Opened. " & gDatabaseName
    
    lblNumRecords.Caption = "Number of Records:" & Str$(xdbRecordCount(gDBFhandle))
    
    Exit Sub
    
Cancel_Open:
    Exit Sub
    
End Sub

Private Sub cmdQuit_Click()

    Unload Me
    
End Sub

Private Sub cmdReadAll_Click()


    'cycle through the database and read each record. Output the
    'display to the listbox.
    
    Load frmList
    
    NumRecords& = xdbRecordCount(gDBFhandle)
    
    For x& = 1 To NumRecords&
      
      Call xdbGetRecord(gDBFhandle, x&)
      
      With frmList.lstRecords
         AcctNum$ = xdbFieldValue$(gDBFhandle, "ACCTNUM", 0)
         AcctName$ = xdbFieldValue$(gDBFhandle, "ACCTNAME", 0)
         .AddItem AcctNum$ & "  " & AcctName$
      End With
    Next
    
    frmList.Show
    
    
End Sub

Private Sub cmdRefresh_Click()
    
    lblNumRecords.Caption = "Number of Records:" & Str$(xdbRecordCount(gDBFhandle))
    
End Sub

Private Sub Form_Load()

    'change to the directory of the EXE
    ChDir App.Path
    
    'activate MultiUser mode
    Call xdbMultiUser(XDBTRUE, 10, 100)
    
    Call SetCommandButtons(False)
    
    
End Sub


Sub SetCommandButtons(enable As Boolean)

    'set the state of the command buttons
    cmdAdd.Enabled = enable
    cmdReadAll.Enabled = enable
    cmdEdit.Enabled = enable
    cmdDelete.Enabled = enable
    cmdClose.Enabled = enable
    
    If enable = False Then
       cmdRefresh.Visible = False
    Else
       cmdRefresh.Visible = True
    End If
    
    lblMessage.Caption = ""
    lblNumRecords.Caption = ""
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    'if the database is still open then close it
    If gDBFhandle > 0 Then
       Call xdbClose(gDBFhandle)
    End If
    
    
    'terminate the Cheetah connection. Sometimes VisualBasic will
    'not release the Cheetah DLL while in the VB IDE.
    Call xdbFreeDLL
    
End Sub