📄 frmmainform.frm
字号:
VERSION 5.00
Begin VB.Form frmMainForm
BorderStyle = 1 'Fixed Single
Caption = "Cheetah Database for Visual Basic"
ClientHeight = 6885
ClientLeft = 45
ClientTop = 330
ClientWidth = 8235
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6885
ScaleWidth = 8235
StartUpPosition = 2 'CenterScreen
Begin VB.PictureBox Picture1
Height = 1005
Left = 2445
ScaleHeight = 945
ScaleWidth = 1035
TabIndex = 24
Top = 5115
Visible = 0 'False
Width = 1095
End
Begin VB.TextBox txtCallbackTextbox
Height = 285
Left = 2760
TabIndex = 23
Top = 6405
Visible = 0 'False
Width = 744
End
Begin VB.CommandButton cmdQuery
Caption = "Query"
Enabled = 0 'False
Height = 495
Left = 3705
TabIndex = 21
Top = 6255
Width = 1035
End
Begin VB.CommandButton cmdRecall
Caption = "Recall"
Enabled = 0 'False
Height = 495
Left = 4815
TabIndex = 20
Top = 5670
Width = 1035
End
Begin VB.Frame frmStatistics
Caption = "Statistics"
Height = 1365
Left = 165
TabIndex = 14
Top = 3660
Width = 7935
Begin VB.Label lblVersion
Caption = "Version:"
Height = 285
Left = 135
TabIndex = 19
Top = 990
Width = 7350
End
Begin VB.Label lblRegisteredTo
Caption = "Registered To:"
Height = 285
Left = 135
TabIndex = 18
Top = 750
Width = 7350
End
Begin VB.Label lblLastUpdated
Caption = "Last Updated:"
Height = 285
Left = 3960
TabIndex = 17
Top = 270
Width = 2850
End
Begin VB.Label lblTotalKeys
Caption = "Total Keys:"
Height = 285
Left = 135
TabIndex = 16
Top = 500
Width = 2535
End
Begin VB.Label lblTotalRecords
Caption = "Total Records:"
Height = 285
Left = 135
TabIndex = 15
Top = 255
Width = 2535
End
End
Begin VB.CommandButton cmdZap
Caption = "Zap"
Enabled = 0 'False
Height = 495
Left = 7065
TabIndex = 13
Top = 5670
Width = 1035
End
Begin VB.CommandButton cmdPack
Caption = "Pack"
Enabled = 0 'False
Height = 495
Left = 5940
TabIndex = 12
Top = 5670
Width = 1035
End
Begin VB.CommandButton cmdMoveLast
Caption = "Last"
Enabled = 0 'False
Height = 495
Left = 7065
TabIndex = 10
Top = 5085
Width = 1035
End
Begin VB.CommandButton cmdMoveNext
Caption = "Next"
Enabled = 0 'False
Height = 495
Left = 5940
TabIndex = 9
Top = 5085
Width = 1035
End
Begin VB.CommandButton cmdMovePrevious
Caption = "Previous "
Enabled = 0 'False
Height = 495
Left = 4815
TabIndex = 8
Top = 5085
Width = 1035
End
Begin VB.CommandButton cmdMoveFirst
Caption = "First"
Enabled = 0 'False
Height = 495
Left = 3690
TabIndex = 7
Top = 5085
Width = 1035
End
Begin VB.CommandButton cmdDelete
Caption = "Delete"
Enabled = 0 'False
Height = 495
Left = 3690
TabIndex = 6
Top = 5670
Width = 1035
End
Begin VB.CommandButton cmdSearch
Caption = "S&earch"
Enabled = 0 'False
Height = 495
Left = 1290
TabIndex = 4
Top = 5085
Width = 1035
End
Begin VB.CommandButton cmdRecords
Caption = "&Records"
Enabled = 0 'False
Height = 495
Left = 1290
TabIndex = 3
Top = 5670
Width = 1035
End
Begin VB.CommandButton cmdStructures
Caption = "&Structures"
Enabled = 0 'False
Height = 495
Left = 165
TabIndex = 2
Top = 5670
Width = 1035
End
Begin VB.CommandButton cmdExit
Caption = "E&xit"
Height = 495
Left = 7065
TabIndex = 5
Top = 6255
Width = 1035
End
Begin VB.CommandButton cmdCreateFiles
Caption = "&Create Files"
Height = 495
Left = 165
TabIndex = 1
Top = 5085
Width = 1035
End
Begin VB.ListBox lstOutput
BackColor = &H00000000&
BeginProperty Font
Name = "Courier"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 2985
Left = 165
TabIndex = 0
Top = 480
Width = 7950
End
Begin VB.Label lblPercentComplete
Caption = "lblPercentComplete"
Height = 288
Left = 192
TabIndex = 22
Top = 6456
Visible = 0 'False
Width = 2364
End
Begin VB.Label lblDatabase
BackColor = &H8000000C&
Caption = " lblDatabase"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000E&
Height = 330
Left = 165
TabIndex = 11
Top = 150
Width = 7935
End
End
Attribute VB_Name = "frmMainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim CreateRecords As Long 'number of records to create
Dim SearchFor As String 'CustId to search for
Private Sub cmdDelete_Click()
'mark the current record for deletion
RecNum& = xdbRecordNumber&(cust.dbHandle)
If RecNum& > 0 Then
Call xdbDeleteRecord(cust.dbHandle, RecNum&)
Call ShowCurrentRecord
End If
End Sub
Private Sub cmdQuery_Click()
Call DoQuery
End Sub
Private Sub cmdRecall_Click()
'mark the current record for deletion
RecNum& = xdbRecordNumber&(cust.dbHandle)
If RecNum& > 0 Then
Call xdbRecallRecord(cust.dbHandle, RecNum&)
Call ShowCurrentRecord
End If
End Sub
Private Sub cmdMoveFirst_Click()
Call xdbMoveFirst(cust.dbHandle, cust.idxHandle)
Call ShowCurrentRecord
End Sub
Private Sub cmdMoveLast_Click()
Call xdbMoveLast(cust.dbHandle, cust.idxHandle)
Call ShowCurrentRecord
End Sub
Private Sub cmdMoveNext_Click()
Call xdbMoveNext(cust.dbHandle, cust.idxHandle)
Call ShowCurrentRecord
End Sub
Private Sub cmdMovePrevious_Click()
Call xdbMovePrev(cust.dbHandle, cust.idxHandle)
Call ShowCurrentRecord
End Sub
Private Sub cmdRecords_Click()
Call ShowDatabaseRecords
End Sub
Private Sub cmdSearch_Click()
result = InputBox("Enter CUSTID to search for:", "Search")
If result = "" Then Exit Sub
SearchFor$ = result
Call DoSearch
End Sub
Private Sub cmdStructures_Click()
Call ShowStructures
End Sub
Private Sub cmdPack_Click()
result = MsgBox("Remove Deleted records from Database & Index?", vbYesNo + vbQuestion, "Pack")
If result = vbYes Then
Call xdbPack(cust.dbHandle)
End If
lstOutput.Clear
Call AddMessage("Database & Index have been Packed & Reindexed.")
'update the statistics
Call UpdateStatistics
End Sub
Private Sub cmdZap_Click()
result = MsgBox("Remove ALL records from Database & Index?", vbYesNo + vbQuestion, "Zap")
If result = vbYes Then
Call xdbZap(cust.dbHandle)
lstOutput.Clear
Call AddMessage("Database & Index have been Zapped.")
End If
'update the statistics
Call UpdateStatistics
End Sub
Private Sub Form_Load()
'change to the applications directory. The Cheetah DLL is in
'this directory so VB can now find it. If you don't change the
'default directory to the application's directory then you
'need to put CHEETAH.DLL in the Windows/System directory.
ChDir App.Path
lblDatabase.Caption = "No Database/Index Active"
Call xdbMultiUser(XDBFALSE&, 0, 0)
End Sub
Private Sub cmdCreateFiles_Click()
'get the # or records to create
result = InputBox("Enter the Number of Records to Create:", "Create Databases", 1000)
If result = "" Then Exit Sub
If IsNumeric(result) Then
CreateRecords& = CLng(result)
Else
CreateRecords& = 1000
End If
'disable this button so we don't re-enter again
cmdCreateFiles.Enabled = False
'if the Cheetah database is already open then close it
'this also closes any associated indexes or memo files.
If cust.dbHandle > 0 Then
Call xdbClose(cust.dbHandle)
cust.dbHandle = 0
cust.idxHandle = 0
End If
Call CreateFiles
'enable the buttons that will manipulate the newly created files
cmdCreateFiles.Enabled = True
cmdStructures.Enabled = True
cmdRecords.Enabled = True
cmdSearch.Enabled = True
cmdMoveFirst.Enabled = True
cmdMovePrevious.Enabled = True
cmdMoveNext.Enabled = True
cmdMoveLast.Enabled = True
cmdDelete.Enabled = True
cmdRecall.Enabled = True
cmdPack.Enabled = True
cmdZap.Enabled = True
cmdQuery.Enabled = True
End Sub
Private Sub cmdExit_Click()
'any open databases/indexes will be closed in the unload event
Unload Me
End Sub
Private Sub CreateFiles()
'***** Create the new database & index *****
cust.dbFileName = "cust.dbf"
cust.IDXfilename = "cust.idx"
lstOutput.Clear
Call AddMessage("Creating Customer Database")
'***** CREATE THE CUSTOMER DATABASE
'create a very simple xBase compatible database. We could also
'use non-standard fields such as currency and binary numbers
'if we wish.
ReDim Fd(1 To 3) As String
Fd(1) = "CUSTID,N,5,0" 'numeric, length 5, no decimals
Fd(2) = "CUSTNAME,C,25,0" 'character, length 25
Fd(3) = "AMOUNT,N,14,2" 'numeric, length 14, 2 decimals
'create the database
Call xdbCreate(cust.dbFileName, Fd())
'check for error during the creation of the database
If xdbError& Then
MsgBox "Error: " & xdbError& & " creating customer database.", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
'***** OPEN THE CUSTOMER DATABASE & CREATE INDEX
Call AddMessage("Opening Customer Database")
'the variable cust.dbHandle has been defined as GLOBAL or PUBLIC in
'the module "SupportModule.bas" so it can be referenced throughout the program
cust.dbHandle = xdbOpen&(cust.dbFileName)
If xdbError& Then
MsgBox "Error: " & xdbError& & " opening customer database.", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
'create the index
IndexExpr$ = "CUSTID"
Duplicates& = XDBTRUE& 'allow duplicate entries in the index
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -