frmmainform.frm

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

    '***** Create the new database*****
     cust.dbFileName = "cust.dbf"
     
     lstOutput.Clear
     Call AddMessage("Creating 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 5) 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
     Fd(4) = "PICTURE,Z,4,0"    'Binary memo field, always length 4
     Fd(5) = "AVI,Z,4,0"        'Binary memo field, always length 4
     
     '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
     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
     
     lblDatabase.Caption = "Database is Open"
     
     
     Call AddMessage("")
     Call AddMessage("Adding records to Database")
     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")
    AVIField& = xdbFieldNumber&(cust.dbHandle, "AVI")
    
    Randomize Timer
    
    '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
    
    CreateRecords& = 10
    
    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((99999 * Rnd) + 1)   'random value between 1 and 99999
      CustID$ = LTrim$(Str$(myValue))
      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$)
      
     
      'Add a picture to the memo file depending on which record number
      'is currently being used.
      Select Case x&
         Case 1
            f& = FreeFile
            Open "binoc.ico" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         
         Case 2
            f& = FreeFile
            Open "rabbit.wmf" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
            
            'also store an AVI clip in the memo file
            f& = FreeFile
            Open "FileCopy.avi" For Binary As #f&
            AVIst$ = Space$(LOF(f&))
            Get #f&, , AVIst$
            Close #f&
            
            
         Case 3
            f& = FreeFile
            Open "tennis.wmf" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
            
         Case 4
            f& = FreeFile
            Open "donkey.wmf" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         
         Case 5
            f& = FreeFile
            Open "dice.wmf" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
            
         Case 6
            f& = FreeFile
            Open "coins.wmf" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
            
         Case 7
            f& = FreeFile
            Open "pebble.gif" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         
            'also store an AVI clip in the memo file
            f& = FreeFile
            Open "FileCopy.avi" For Binary As #f&
            AVIst$ = Space$(LOF(f&))
            Get #f&, , AVIst$
            Close #f&
         
         Case 8
            f& = FreeFile
            Open "bigwand.bmp" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         Case 9
            f& = FreeFile
            Open "deletemark.bmp" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         Case 10
            f& = FreeFile
            Open "balloon.jpg" For Binary As #f&
            PictureSt$ = Space$(LOF(f&))
            Get #f&, , PictureSt$
            Close #f&
         
      End Select
         
      If PictureSt$ > "" Then
         Call xdbAssignField(cust.dbHandle, "", PictureField&, PictureSt$)
         PictureSt$ = ""
      End If
      
      If AVIst$ > "" Then
         Call xdbAssignField(cust.dbHandle, "", AVIField&, AVIst$)
         AVIst$ = ""
      End If
      
      
      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"
    
    
    Call AddMessage("Sample Database Data Created.")
    
    DBFrecords& = xdbRecordCount&(cust.dbHandle)
    Call AddMessage("Total Database records added: " & DBFrecords&)
    
    Call AddMessage("Time to Append " & DBFrecords& & " records: " & AppendElapsedTime$)
    
End Sub


Private Sub ShowCurrentRecord()

Static ActiveAnimation&
Static AVITempFile$

    
    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)
    pic$ = xdbFieldValue$(cust.dbHandle, "", 4)  'BLOB picture
    AVIst$ = xdbFieldValue$(cust.dbHandle, "", 5)  'BLOB animation
    
    Call AddMessage(st1$)
    Call AddMessage(st2$)
    Call AddMessage(st3$)
    Call AddMessage(RecNum$)
    
    'check to see if an AVI file is already running
    If ActiveAnimation& = True Then
       Animation1.AutoPlay = False
       Animation1.Close
       ActiveAnimation& = False
       If Dir$(AVITempFile$) > "" Then Kill AVITempFile$
    End If
    
    
    If Len(pic$) Then
       'update the picture box with the picture that is
       'in the memo file.
       
       'create a temporary file to store the binary data.
       'The programmer must delete this file when finished with it.
       TempFile$ = CreateTempFile$(pic$)
              
       Picture1.Picture = LoadPicture(TempFile$)
       Picture1.Visible = True
       
       'delete the temp file because we don't need it anymore
       If Dir$(TempFile$) > "" Then Kill TempFile$
       
    Else
       'there is no picture in the memo file so just
       'blank it out.
       Set Picture1.Picture = Nothing
    End If
    
    If Len(AVIst$) Then
       'create a temporary file to store the binary data.
       'The programmer must delete this file when finished with it.
       AVITempFile$ = CreateTempFile$(AVIst$)
             
       With Animation1
          .AutoPlay = True
          .Open AVITempFile$
          'set flag to show animation is active
          ActiveAnimation& = True
       End With
       
       'can not delete the AVI tempfile until we move to another record
       'because the AVI control requires the AVI until the .Close command
       'is called.
    
    End If
    
   
    If xdbDeleted&(cust.dbHandle, xdbRecordNumber&(cust.dbHandle)) = 0 Then
       Deleted$ = "No "
    Else
       Deleted$ = "Yes"
    End If
    
    Call AddMessage("Deleted: " & Deleted$)
    
    
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



Function CreateTempFile$(BinaryData$)

    'create a temp file using the Windows API by calling
    'the Cheetah function xdbTempFileName$. This will create
    'a unique filename in the TEMP directory as specified by Windows.
    
    TempFileName$ = xdbTempFileName$
    
    'store the binary data to the temp file
    t& = FreeFile
    Open TempFileName$ For Binary As #t&
    Put #t&, , BinaryData$
    Close #t&
    
    CreateTempFile$ = TempFileName$

End Function