frmmainform.frm

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

     
     Call xdbCreateIndex(cust.IDXfilename, cust.dbHandle, IndexExpr$, Duplicates&)
     If xdbError& Then
        MsgBox "Error: " & xdbError& & " creating customer index.", vbCritical + vbOKOnly, "Error"
        Exit Sub
     End If
     
     'open the index
     cust.idxHandle = xdbOpenIndex&(cust.IDXfilename, cust.dbHandle)
     If xdbError& Then
        MsgBox "Error: " & xdbError& & " opening customer index.", vbCritical + vbOKOnly, "Error"
        Exit Sub
     End If
     
     
     lblDatabase.Caption = "Customer Database and Index Open"
     
     
     Call AddMessage("")
     Call AddMessage("Adding records to Customer Database & Index")
     DoEvents
   
    'predefine the field#'s for speed. If you already know the
    'which field name corresponds to which field number then
    'there is no need to do this. These functions provide
    'really fast lookups.
    CustIDfield& = xdbFieldNumber&(cust.dbHandle, "CUSTID")
    CustNameField& = xdbFieldNumber&(cust.dbHandle, "CUSTNAME")
    AmountField& = xdbFieldNumber&(cust.dbHandle, "AMOUNT")
    PictureField& = xdbFieldNumber&(cust.dbHandle, "PICTURE")
    
    Randomize
    
    'set the SpeedAppend function to speed up writing database data
    Call xdbSpeedAppend(cust.dbHandle, XDBTRUE&)
    
    'set the timer to see how long it takes to append/reindex the records
    starttime! = Timer
    
    For x& = 1 To CreateRecords&
     'Clear the record buffer. If you need to assign the same value
     'to multiple records then do not clear the buffer. In this case
     'the same values will be brought forward to the next record. This
     'is similar to xBase's CARRY ON command.
      Call xdbClearBuffer(cust.dbHandle)
    
      myValue = Int((89999 * Rnd) + 1)   'random value between 1 and 89999
      CustID$ = LTrim$(Str$(myValue + 10000)) 'CustID should now be 5 digits
      CustName$ = "Customer Name# " & myValue
      Amount$ = (10000 + x&) / 100
      
      Call xdbAssignField(cust.dbHandle, "", CustIDfield&, CustID$)
      Call xdbAssignField(cust.dbHandle, "", CustNameField&, CustName$)
      Call xdbAssignField(cust.dbHandle, "", AmountField&, Amount$)
      
      
      'Calling xdbAddRecord will add the record to the database and also update any
      'open indexes that relate to this database. If you attempt to add a duplicate
      'record where an index is set for NO DUPLICATES then the xdbAddRecord function
      'will return an error and the database record will not be added.
      'Call xdbAddRecord(cust.dbHandle)
      
      'instead of calling the xdbAddRecord function I will use the xdbAppendRecord
      'function and then reindex the database after appending the records. Reindexing
      'after appending records is *much* faster than updating the indexes one
      'record at a time with xdbAddRecord.
      
      Call xdbAppendRecord(cust.dbHandle)
      
      If xdbError& Then
         MsgBox "Error: " & xdbError& & " adding customer record.", vbCritical + vbOKOnly, "Error"
         Exit For
      End If
      
    Next
    
    'turn off the speed appends - this also writes any records
    'still in the speed buffer - don't forget to do this if you
    'use xdbSpeedAppend!
    Call xdbSpeedAppend(cust.dbHandle, XDBFALSE&)
    
    endtime! = Timer
    AppendElapsedTime$ = Format((endtime! - starttime!), "0.####") & " secs"
    
    'reindex the databases
    'set up the callback routine so the percentage
    'of completion of the reindexing. You should note that the reindex will perform
    'faster if you do not set the callback because the reindexing will not be
    'interrupted to update the percentage completion on the screen.
    Call xdbSetCallback(txtCallbackTextbox.hWnd)
    
    starttime! = Timer
    
    Call xdbReindexAll(cust.dbHandle)
    
    endtime! = Timer
    
    ReindexElapsedTime$ = Format((endtime! - starttime!), "0.####") & " secs"
    
    If xdbError& Then
       MsgBox "Error: " & xdbError& & " Reindexing database.", vbCritical
    End If
    
    
    'reset the callback routine
    Call xdbSetCallback(0)
    
    lblPercentComplete.Visible = False
    
    
    Call AddMessage("Sample Customer Data Created. Indexed on CUSTID.")
    
    DBFrecords& = xdbRecordCount&(cust.dbHandle) '+ xdbRecordCount&(orders.dbHandle)
    IDXrecords& = xdbKeyCount&(cust.dbHandle, cust.idxHandle) '+ xdbKeyCount&(orders.dbHandle, orders.idxHandle) '+ xdbKeyCount&(orders.dbHandle, orders.idxHandle2)
    
    Call AddMessage("Total Database records added: " & DBFrecords&)
    Call AddMessage("Total Index records added: " & IDXrecords&)
    
    Call AddMessage("Time to Append " & DBFrecords& & " records: " & AppendElapsedTime$)
    
    Call AddMessage("Time to Reindex " & DBFrecords& & " records: " & ReindexElapsedTime$)
    
    Call UpdateStatistics
     
   
    
End Sub



Private Sub ShowStructures()

'display the structures of the databases
lstOutput.Clear

 '***** Display the Customer database structure *****
 Call AddMessage("Customer Database Structure")
 DoEvents


 Call AddMessage("")
 st$ = "FIELDNAME    TYPE  LENGTH  DECIMALS"
 Call AddMessage(st$)
 st$ = "==================================="
 Call AddMessage(st$)
 
 
 NumFields& = xdbFieldCount&(cust.dbHandle)
 
 For x& = 1 To NumFields&
    st$ = Space$(35)
    Call xdbFieldInfo(cust.dbHandle, x&, FieldName$, FieldType$, FieldLength&, NumDecimals&)
    Mid$(st$, 1) = FieldName$
    Mid$(st$, 15) = FieldType$
    Mid$(st$, 22) = FieldLength&
    Mid$(st$, 31) = NumDecimals&
    lstOutput.AddItem st$
 Next
 
 
 DoEvents

End Sub


Private Sub ShowDatabaseRecords()

lstOutput.Clear


 '***** Cycle through the records (DO/LOOP MOVE COMMANDS - FORWARD) *****
 '***** The active index is used for ordering *****
 
 Call AddMessage("")
 TotalRecords& = xdbRecordCount&(cust.dbHandle)
 Call AddMessage("Show " & TotalRecords& & " Records using Do/Loop (FORWARD) Index: CUSTID")

 Call AddMessage("")
 
 st1$ = "CustID CustName                          Amount   Rec#"
 st2$ = "======================================================"
 Call AddMessage(st1$)
 Call AddMessage(st2$)
 
     
     
     'if you want to access the database in its natural order without an
     'active index then simply pass the value of zero (0) to the second
     'parameter of the xdbMove functions. For example:
     'Call xdbMoveFirst(cust.dbHandle, 0)
 
 Call xdbFieldPadding(cust.dbHandle, True)
 Call xdbMoveFirst(cust.dbHandle, cust.idxHandle)

 'show the record's contents in the listbox
 NumFields& = xdbFieldCount&(cust.dbHandle)  'number of fields in each record
 
 Do Until xdbEOF&(cust.dbHandle) <> 0

    RecNum$ = Space$(6)
    RSet RecNum$ = Str$(xdbRecordNumber&(cust.dbHandle))
    
    st$ = ""
    
    For x& = 1 To NumFields&
      'there are two ways I can show the record.
      '(1) by just displaying the entire raw record with xdbRecordBuffer
      '(2) access the individual fields and build a string to show
      'I will use the second method for illustration. This also assumes
      'that all fields are either C,D,L,N types. If binary field types are
      'used then a check must be done first.
      FieldType$ = xdbFieldType$(cust.dbHandle, x&)

      Select Case FieldType$
        Case "C", "D", "L", "N", "M", "Z"
           st$ = st$ & " " & xdbFieldValue$(cust.dbHandle, "", x&)
        Case "I"  'integer
           st$ = st$ & " " & Str$(xdbFieldValueINT(cust.dbHandle, "", x&))
        Case "W"  'long
           st$ = st$ & " " & Str$(xdbFieldValueLNG(cust.dbHandle, "", x&))
        Case "S"  'single
           st$ = st$ & " " & Str$(xdbFieldValueSNG(cust.dbHandle, "", x&))
        Case "X"  'double
           st$ = st$ & " " & Str$(xdbFieldValueDBL(cust.dbHandle, "", x&))
        Case "Y"  'currency
           st$ = st$ & " " & Str$(xdbFieldValueCUR(cust.dbHandle, "", x&))
     End Select

    Next

    Call AddMessage(st$ & " " & RecNum$)

    Call xdbMoveNext(cust.dbHandle, cust.idxHandle)
 Loop


End Sub



Private Sub UpdateStatistics()

    lblRegisteredTo.Caption = "Registered To: " & xdbRegisteredTo$
    lblVersion.Caption = "Version: " & xdbVersion$
    lblTotalRecords.Caption = "Record Count: " & xdbRecordCount&(cust.dbHandle)
    lblTotalKeys.Caption = "Key Count: " & xdbKeyCount&(cust.dbHandle, cust.idxHandle)
    
    Call xdbLastUpdated(cust.dbHandle, YearNo&, MonthNr&, DayNr&)
    LastUpdated$ = LTrim$(Str$(YearNo&)) & "-" & LTrim$(Str$(MonthNr&)) & "-" & LTrim$(Str$(DayNr&))
    lblLastUpdated.Caption = "Last Updated: " & LastUpdated$
End Sub



Private Sub ShowCurrentRecord()

    lstOutput.Clear
    
    If xdbRecordNumber&(cust.dbHandle) = 0 Then
       Call AddMessage("No records in database.")
       Exit Sub
    End If
    
    Call AddMessage("")
    
    RecNum$ = "Record#:  " & xdbRecordNumber&(cust.dbHandle)
    st1$ = "CustID:   " & xdbFieldValue$(cust.dbHandle, "", 1)
    st2$ = "CustName: " & xdbFieldValue$(cust.dbHandle, "", 2)
    st3$ = "Amount:   " & xdbFieldValue$(cust.dbHandle, "", 3)
    
    Call AddMessage(st1$)
    Call AddMessage(st2$)
    Call AddMessage(st3$)
    Call AddMessage(RecNum$)
    
    If xdbDeleted&(cust.dbHandle, xdbRecordNumber&(cust.dbHandle)) = 0 Then
       Deleted$ = "No "
    Else
       Deleted$ = "Yes"
    End If
    
    Call AddMessage("Deleted: " & Deleted$)
    
    Call UpdateStatistics
    
End Sub



Private Sub DoSearch()


 lstOutput.Clear
 
 '***** Search for records *****
 Call AddMessage("")
 Call AddMessage("Search for CUSTID: " & SearchFor$)
 
 'if you want to search on a partial key then only specify the portion
 'of the key you want to match on. Do not pad the key to the entire
 'key length.
 '
 'For example:
 '
 '    To seek on partial match for CustID = 203 then only specify the
 '    search key to be "203". Do not pad the key to "203  " because Cheetah
 '    will attempt to partial match the spaces as well. You want to partially
 '    match the 3 characters, not the 5 characters.
 
 
 Dim ExactSearch As Boolean
 
 'perform the seek
 stat& = xdbSeek&(cust.dbHandle, cust.idxHandle, SearchFor$)
 
 If stat& = 0 Then
    result = MsgBox("Match not found. Perform a 'Partial match' search instead?", vbYesNo + vbQuestion, "Search Results")
    If result = vbYes Then
       stat& = xdbSeekPartial&(cust.dbHandle, cust.idxHandle, SearchFor$)
       ExactSearch = False
    End If
 Else
    MsgBox "CUSTID: " & SearchFor$ & " found. Press OK to display the matches.", vbOKOnly, "Search Results"
    ExactSearch = True
 End If


 'display the matching records
 lstOutput.Clear
 
 Call AddMessage("")
 
 st1$ = "CustID CustName                          Amount   Rec#"
 st2$ = "======================================================"
 Call AddMessage(st1$)
 Call AddMessage(st2$)

 Call xdbFieldPadding(cust.dbHandle, True)
 
 'show the record's contents in the listbox
 NumFields& = xdbFieldCount&(cust.dbHandle)  'number of fields in each record
 
 Do Until stat& = 0
    'loop until no more Exact matches or Partial matches
    If xdbEOF&(cust.dbHandle) <> 0 Then Exit Do

    RecNum$ = Space$(6)
    RSet RecNum$ = Str$(xdbRecordNumber&(cust.dbHandle))
    
    st$ = ""
    
    For x& = 1 To NumFields&
      'there are two ways I can show the record.
      '(1) by just displaying the entire raw record with xdbRecordBuffer
      '(2) access the individual fields and build a string to show
      'I will use the second method for illustration. This also assumes
      'that all fields are either C,D,L,N types. If binary field types are
      'used then a check must be done first.
      FieldType$ = xdbFieldType$(cust.dbHandle, x&)

      Select Case FieldType$
        Case "C", "D", "L", "N", "M", "Z"
           st$ = st$ & " " & xdbFieldValue$(cust.dbHandle, "", x&)
        Case "I"  'integer
           st$ = st$ & " " & Str$(xdbFieldValueINT(cust.dbHandle, "", x&))
        Case "W"  'long
           st$ = st$ & " " & Str$(xdbFieldValueLNG(cust.dbHandle, "", x&))
        Case "S"  'single
           st$ = st$ & " " & Str$(xdbFieldValueSNG(cust.dbHandle, "", x&))
        Case "X"  'double
           st$ = st$ & " " & Str$(xdbFieldValueDBL(cust.dbHandle, "", x&))
        Case "Y"  'currency
           st$ = st$ & " " & Str$(xdbFieldValueCUR(cust.dbHandle, "", x&))
     End Select

    Next

    Call AddMessage(st$ & " " & RecNum$)

    If ExactSearch = True Then
       stat& = xdbSeekNext(cust.dbHandle, cust.idxHandle, SearchFor$)
    Else
       stat& = xdbSeekPartialNext(cust.dbHandle, cust.idxHandle, SearchFor$)
    End If
 Loop



End Sub




Private Sub DoQuery()

'***** Perform a query much like a SQL statement *****

'perform a query to find all Customers whose CustID's are < 2000

lstOutput.Clear
msg$ = "Query Customers where CUSTID < 20000"
Call AddMessage(msg$)
Call AddMessage("")


'each query must be specified by a unique handle. The xdbCreateQuery function allocates
'space for the query and returns a valid query handle.
  Query1& = xdbCreateQuery&(cust.dbHandle)

  If xdbError& Then
     MsgBox "Error" & Str$(xdbError&) & " creating query"
     Exit Sub
  End If

'build the query by specifying "conditions". The following are specially defined constants
'for each equality.
' EQUAL_TO& = 1
' NOT_EQUAL_TO& = 2
' LESS_THAN& = 3
' GREATER_THAN& = 4
' LESS_THAN_EQUAL_TO& = 5
' GREATER_THAN_EQUAL_TO& = 6
' CONTAINS& = 7
' BETWEEN& = 8

  Call xdbQueryCondition(Query1&, 0, "CUSTID", LESS_THAN&, "20000", "")
  Call xdbQueryCondition(Query1&, 0, "AMOUNT", SUM&, "", "")
  Call xdbQuerySort(Query1&, "CUSTID", SORT_ASCEND&)

'the query is created when you call xdbQueryExecute
  starttime! = Timer
  Call xdbQueryExecute(Query1&)
  endtime! = Timer

  msg$ = "Time for query: " & Format$(endtime! - starttime!, "0.####") & " secs." & vbCrLf & "NumRecords:" & Str$(xdbRecordCount&(Query1&))
  MsgBox msg$, vbOKOnly, "Cheetah Query"

'display the query results
  Call xdbMoveFirst(Query1&, 0)  'queries do not require the index parameter - it would be ignored anyway.

  Do Until xdbEOF&(Query1&)
     Call AddMessage(xdbRecordBuffer$(Query1&))
     Call xdbMoveNext(Query1&, 0)
  Loop

Text1 = xdbQuerySUM#(Query1&, "AMOUNT")

'destroy the query so the memory can be used again
  Call xdbDestroyQuery(Query1&)



End Sub


Private Sub Form_Unload(Cancel As Integer)

'close any open databases/indexes
    If cust.dbHandle > 0 Then
       Call xdbClose(cust.dbHandle)  'this closes the index as well
    End If
    
    
'unload the Cheetah DLL with a call to the xdbFreeDLL function. This is
'necessary because the Visual Basic IDE does *not* unload the DLL until the
'VB IDE is exited. This is a problem if the programmer wants to run the
'source code more than once in the IDE.
    Call xdbFreeDLL
    
End Sub


Private Sub txtCallbackTextbox_Change()

'update the percentage complete label
    With lblPercentComplete
       .Visible = True
       .Caption = "Reindexing Complete: " & txtCallbackTextbox.Text
       .Refresh  'to make sure the label repaints
    End With
       
End Sub