
' PartialSeek
' Code to create a dBase database and perform partial seek matches.

' This demo uses the PowerBASIC Console compiler.


#Compile Exe

#Include "Cheetah4_PowerBasic.inc"

'JPRO_COMPILER=PB/CC


Function PBMain() As Long
   
   Local dbfHandle  As Long        
   Local idxHandle  As Long
   Local tagHandle1 As Long
   Local errcode    As Long
   Local nRecNum    As Long
   Local sData      As String
   Local sLookfor   As String
   Local sKeyValue  As String
   Local st         As String
   Local i          As Long                         
   
   Cls
   
   '// CREATE A DBASE COMPATIBLE DATABASE 
   sData = "disk  = dbasetest.dbf;"    & _  
           "type  = dbase;"            & _
           "field = custid,c,8,0;"     & _     ' character
           "field = firstname,c,20,0;" & _     ' character
           "field = lastname,c,20,0;" 

   errcode = xdbCreateDatabase( sData )
   Print "create database:"; errcode 
   If errcode Then GoTo ExitOut
   Print "Database created."

   sData = "disk = dbasetest.btx;"  
   errcode = xdbCreateIndex( sData ) 
   If errcode Then GoTo ExitOut
   Print "Index created"
   
   sData = "disk=dbasetest.dbf"
   errcode = xdbOpenDatabase( sData, dbfHandle ) 
   If errcode Then GoTo ExitOut
   Print "Database opened. Handle ="; Str$( dbfHandle )                  
                  
   sData = "disk=dbasetest.btx"
   errcode = xdbOpenIndex( sData, dbfHandle, idxHandle ) 
   If errcode Then GoTo exitout
   Print "Index opened. Handle ="; Str$( idxHandle )                  

   sData = "TagName=lastname; Expression=lastname; UpperCase=TRUE"
   errcode = xdbCreateTag( sData, idxHandle ) 
   If errcode Then GoTo exitout
   Print "Tag 'lastname' created"


   '// ADD RECORDS TO THE DATABASE
   xdbClearBuffer dbfHandle
   
   xdbSetField dbfHandle, "custid",    0, "1000"
   xdbSetField dbfHandle, "firstname", 0, "Paul"
   xdbSetField dbfHandle, "lastname",  0, "Squires"

   errcode = xdbPutRecord( dbfHandle, 0 )
   If errcode Then GoTo exitout
   
      
   '// ADD 10 RECORDS WITH LAST NAME STARTING WITH SMITH
   For i = 1 To 10
      xdbClearBuffer dbfHandle
      
      xdbSetField dbfHandle, "custid",    0, Format$(Rnd(1000, 9999))
      xdbSetField dbfHandle, "firstname", 0, "Bill"
      xdbSetField dbfHandle, "lastname",  0, "Smith" & Format$(Rnd(1000, 2000))
      xdbSetField dbfHandle, "amountdue", 0, "500.00"
      xdbSetField dbfHandle, "lastpymt",  0, "20050930"
      xdbSetField dbfHandle, "isactive",  0, "T"          ' True
      xdbSetField dbfHandle, "notes",     0, "This is my note for record 2"
      
      errcode = xdbPutRecord( dbfHandle, 0 )
      If errcode Then GoTo exitout
   Next
   

   '// ADD A LAST RECORD
   xdbClearBuffer dbfHandle
   
   xdbSetField dbfHandle, "custid",    0, "1500"
   xdbSetField dbfHandle, "firstname", 0, "Mary"
   xdbSetField dbfHandle, "lastname",  0, "Beckworth"
   
   errcode = xdbPutRecord( dbfHandle, 0 )
   If errcode Then GoTo exitout

   

   '// PERFORM PARTIAL SEEK ON THE LASTNAME TAG
   ' We search for partial matches by passing the exact size
   ' of the partial match string we are looking for. To find
   ' all "Smith" we would pass a string of size 5 rather than
   ' the full size of the field (20).
   errcode = xdbGetTag( "lastname", idxHandle, tagHandle1 ) 

   sLookfor = "SMITH" 

   If xdbSeek( tagHandle1, sLookfor, nRecNum ) = %ERR_SEEKPARTIALMATCH Then

      Do Until errcode = %ERR_MOVEERROR
         xdbGetKey tagHandle1, sKeyValue, nRecNum 
         If Left$(UCase$(sKeyValue), Len(sLookFor)) <> sLookFor Then Exit Do
         
         xdbGetRecord dbfHandle, nRecNum                                              
         If xdbIsDeleted( dbfHandle ) = %FALSE Then
            xdbGetField dbfHandle, "lastname", 0, %TRUE, st
            Print "Match for "; sLookfor; " in Tag:custid at RecNum"; Str$(nRecNum); " lastname="; st
         End If
   
         errcode = xdbMove( dbfHandle, tagHandle1, %XDB_MOVENEXT, nRecNum )
         
         ' It is even faster to use MOVENEXT_ATOMIC if you know that the
         ' index has not been modified since the last seek was performed.
         'errcode = xdbMove( dbfHandle, tagHandle1, %XDB_MOVENEXT_ATOMIC, nRecNum )
      Loop

   End If     


   '// CLOSE THE DATABASE AND INDEX(ES)
   ' Closing the database will automatically close all indexes associated
   ' with it. The xdbShutDown command will also close the databases and
   ' indexes if you fail to remember to close them prior to the program ending.
   errcode = xdbCloseDatabase( dbfHandle ) 
   If errcode Then GoTo exitout
   Print "Database and index closed."
   
ExitOut:

   '// SHUTDOWN THE SYSTEM (This will close files and free internal allocated memory)
   xdbShutdown

   Print "Demo Completed"
   
   While InKey$ = "": Wend
        
End Function

