QBasic & Borland Pascal & C/Delphi5.iso/Basic/Samples/BOZOL2/BOZOL2.ZIP/DB.BAS

BASIC Source File | 1994-02-08 | 34.4 KB | 1,022 lines

'       DBASE III COMPATIBLE DATA FILE INTERFACE for PowerBASIC 3.0+
'
' dBASE interface, screen field editing, and indexing routines by Erik Olson
' with Joe Vest's BT() BTree subroutine and a modified field input routine
' by David Zarnitsky.  Special thanks to Bob Zale for making me do this.

' Routine list (detailed descriptions follow)

' dBASE .DBF file access
'    dBUse(STRING,INTEGER)
'    dBGetRecord(DWORD,INTEGER)
'    dBGetCField$(STRING,INTEGER)
'    dBGetNField!(STRING,INTEGER)
'    dBPutRecord(DWORD,INTEGER)
'    dBPutCField(STRING, STRING, INTEGER)
'    dBPutNField(STRING, SINGLE, INTEGER)

' utilities
'    dBGetASCII$()
'    dBGetARRAY(STRING ARRAY,INTEGER)
'
' index support
'    dBSetIndexTo(IX$,Fld$,e%)
'    dBCreateIndex(IX$, Fld$, e%)
'    dBSearchIndex(Findme$,e%)
'    dBSkip(NS%, e%)
'    dBGotoTop(e%)
'    dBGotoBottom(e%)

' screen editing
'    dBCreateFormat ()
'    dBSetFormatTo (FormatFileName$,Ecode%)
'    dBView ()
'    dBEditFields (Ecode%)
'    dBEditRecord (RecNum???,E%)
'    dBAppendRecord (E%)

%FALSE = 0
%TRUE = NOT %FALSE
%INSERTSCAN = 3           ' Change these two to change shape of cursor
%OVERWRITESCAN = 6        ' The higher the number, the smaller the cursor


' SUB or FUNCTION declaration            Example use and description
'====================================    ===========================
DECLARE SUB dBUse(STRING,INTEGER)      ' dBUse "TEST.DBF", ErrorCode%
                       '  ErrorCode returns
                       '   1 - file not found
                       '   2 - Zero byte file
                       '   3 - File has no fields
                       '   4 - not a dBASE file

DECLARE SUB dBGetRecord(DWORD,INTEGER) ' dBGetRecord R???, ErrorCode%
                       ' ErrorCode returns
                       '   1 - database not open
                       '   2 - record exceeds size
                       '   3 - record => zero

DECLARE FUNCTION dBGetCField$(STRING,INTEGER)
                       ' ErrorCode 1 if no such field
                       ' A$=dBGetCField$("PHONE",e%)
                       ' returns the string value of a
                       ' character field

DECLARE FUNCTION dBGetNField!(STRING,INTEGER)
                       ' A! = dBGetNField!("TOTAL",e%)
                       ' ErrorCode 1 if no such field
                       ' Returns a single precision number
                       ' of a numeric field with proper
                       ' decimal places

DECLARE SUB dBPutRecord(DWORD,INTEGER) ' dBPutRecord(R???,ErrorCode%)
                       ' Returns error 1 if no dbase open
                       ' Returns error 2 if record too hi
                       ' Puts the current record in memory
                       ' into the database at the record
                       ' specified.  If record number is
                       ' 1 higher than NumberOfRecords???
                       ' or if it is 0 then the record will
                       ' be appended to the database

DECLARE SUB dBPutCField(STRING, STRING, INTEGER)
                       ' dBPutCField "NAME", "Erik", Ecode%
                       ' returns error if no such field
                       ' places a string value into a
                       ' character field in memory

DECLARE SUB dBPutNField(STRING, SINGLE, INTEGER)
                       ' dBPutNField "AGE", 27, Ecode%
                       ' returns error if no such field
                       ' places a numeric value into a
                       ' character field in memory.  Numeric
                       ' argument is formatted according to
                       ' the design of the field

DECLARE SUB dBCreateFormat ()          ' runs a mini program to create a
                       ' data entry screen format.  The
                                       ' current format or a default format
                                       ' (of up to 44 fields) is created.
                                       ' you then move the fields around
                                       ' on the screen with the arrow
                                       ' keys and press ENTER when finished.

DECLARE SUB dBSetFormatTo(FormatFileName$,Ecode%)
                    ' dBSetFormatTo "SCREEN1.FRM", E%
                                        ' Loads screen edit format file and
                                        ' returns.  If not successful error
                                        ' code returns 1 for file not found.
                                        ' If filename is nul string then
                                        ' the current format is cleared.
                                        ' Ecode% returns 1 if the format
                                        ' file is not found.

DECLARE SUB dBView ()            ' Uses the current screen format to
                    ' simply display the current record.
                                        ' it does not pause.

DECLARE SUB dBEditFields(Ecode%)        ' uses the current screen format to
                    ' display and then allow editing of
                                        ' the current record in typical
                                        ' dBASE fashion.  CTRL-END or F10
                                        ' terminates and updates the record.
                                        ' ESCAPE terminates and does not
                                        ' update the record.

DECLARE SUB dBEditRecord(RecNum???,E%)  ' Gets a record and allows fullscreen
                    ' editing using current screen format
                                        ' or default screen format if no
                                        ' current format is set.  e% returns
                                        ' 1 if the specified record does not
                                        ' exist.

DECLARE SUB dBAppendRecord(E%)          ' Creates a blank record and allows
                    ' full screen editing.  If the record
                                        ' is not aborted it will be appended
                                        ' to the database.  Uses the current
                                        ' screen format or default format if
                                        ' no format is set.  e% returns 1 if
                                        ' the record cannot be appended to
                                        ' the database for whatever reason.

DECLARE FUNCTION dBGetASCII$()         ' A$ = dBGetASCII$
                       ' returns a comma delimited ASCII
                       ' record of the entire dBASE record
                       ' currently in memory

DECLARE SUB dBGetARRAY(STRING ARRAY,INTEGER)
                       ' dBGetARRAY DB$,e%
                       ' fills the specified array with
                       ' consecutive fields from the entire
                       ' dBASE record currently in memory.
                       ' ErrorCode 1 is array is too small

DECLARE SUB dBSetIndexTo(IX$,Fld$,e%)      ' Set index to file in IX$.  You must
                                        ' specify the field which is being
                                        ' indexed in order to properly update
                                        ' the index during append or edit
                                        ' operations.  The index must have
                                        ' already been created using
                                        ' dBCreateIndex.  E% returns 1 if the
                                        ' database is not open, 2 if the
                                        ' specified field is not in the
                                        ' database, 3 if the index file
                                        ' does not exist

DECLARE SUB dBCreateIndex(IX$, Fld$, e%)' Creates an index file specified in
                    ' IX$.  You must specify the field
                                        ' to index in FLD$.  As the file is
                                        ' being indexed, record numbers are
                                        ' printed to the screen at the
                                        ' current cursor location.  e%
                                        ' returns 1 if the database is not
                                        ' open, 2 if the field does not
                                        ' exist, 3 if the index can't be
                                        ' created on disk, 4 if there is
                                        ' an error reading the database,
                                        ' 5 if the user aborts with ESC,
                                        ' 6 if there is an internal error
                                        ' extracting the field from the
                                        ' record, or 7 if there is an error
                                        ' writing to the index file (like
                                        ' the disk fills up).

DECLARE SUB dBSearchIndex(Findme$,e%)   ' The current index (specified in
                    ' dBSetIndexTo) is searched for
                                        ' a match or closest match (next
                                        ' higher) to the string in Findme$.
                                        ' Index searches are case-INsensative
                                        ' When a match or closest match is
                                        ' found, the actual indexed field is
                                        ' returned in FindMe$, so you can
                                        ' test it against what was originally
                                        ' passed to it.  The matching or
                                        ' closest matching record is loaded.
                                        ' IF NO INDEX HAS BEEN SET, this
                                        ' routine will prompt if you want
                                        ' to sequentially scan the database
                                        ' for a match in any field.  e%
                                        ' returns 1 if no database is open,
                                        ' or if there is an error reading
                                        ' the index or database.  Not too
                                        ' specific, huh?

DECLARE SUB dBSkip(NS%, e%)        ' Skips the number of records
                    ' specified in NS%, either physically
                                        ' of via the index if one has been
                                        ' set.  Notice NS% is an integer.
                                        ' e% returns 1 if something goes
                                        ' wrong in the skip operation.  If
                                        ' you skip physically beyond the end
                                        ' or before record 1, you will get
                                        ' the highest record, or record 1.

DECLARE SUB dBGotoTop(e%)        ' Goes to record 1 or to the first
                    ' record in the index if one has
                                        ' been set.  e% returns 1 if there
                                        ' is an error in this operation or
                                        ' -2 if there is an index error

DECLARE SUB dBGotoBottom(e%)        ' Goes to the last record in the
                    ' database or to the last record in
                                        ' the index if one has been set.
                                    ' e% returns 1 if there is an error
                                        ' or -2 if the index returns an
                                        ' error.

OPTION BINARY BASE 1

'THE FOLLOWING STRUCTURES ARE DIMENSIONED AS SHARED.  USE THEM IN GOOD HEALTH

TYPE DBaseHeaderRecord
        Ver AS BYTE         ' dBASE version
       Year AS BYTE         ' year
      Month AS BYTE         ' month
        Day AS BYTE         ' day of last update
NumberOfRecords AS DWORD        ' number of records in this database
         offset AS WORD         ' length of header
       Size AS WORD         ' length of record
      Blank AS STRING * 20  ' reserved for future use
END TYPE

TYPE DBaseFieldRecord
   FieldName AS STRING * 11  ' name of the field in ASCII
   FieldType AS STRING * 1   ' Type CNLM or D
     FDA AS DWORD        ' field data address - we don't need this
    FLen AS BYTE         ' Length, we'll need this!
    DecC AS BYTE         ' number of decimals in numeric field
      Blank9 AS STRING * 14  ' reserved for future use
END TYPE

TYPE DBStructureRecord
    FieldName AS STRING * 11
    FieldType AS STRING * 1
    FieldLength AS BYTE
    FieldOffset AS INTEGER
    FieldDecimals AS BYTE
    END TYPE

TYPE DBaseEditFormat
        FieldName AS STRING * 11
        FieldType AS STRING * 1
        FieldLength AS BYTE
        FieldRow AS INTEGER
        FieldCol AS INTEGER
        FieldFG AS INTEGER
        FieldBG AS INTEGER
END TYPE


DIM DBH AS DBaseHeaderRecord
DIM DBF AS DBaseFieldRecord
DIM DBS(256) AS DBStructureRecord
DIM DBE(256) AS DBaseEditFormat

SHARED DBH, DBF, DBS(), dBaseOpen%, RecNum???, NumberOfFields?, RecordBlock$
SHARED DBE(), NumberOfRecords???, Index$, IndexField$, IndexField?
SHARED Bt.Update.Always%, Act.Keys$
' THE FOLLOWING VARIABLES ARE SHARED AND CONTAIN USEFUL STATUS INFORMATION

 BT.Update.Always% = -1 ' for Vest BTree indexing
    dBaseOpen% = 0  ' Integer contains buffer number if database open
     RecNum??? = 0  ' Current record number
   NumberOfFields? = 0  ' Number of fields in current database
      RecordBlock$ = "" ' Contains binary image of current record
      ErrCode% = 0  ' Return code used by subs and functions for errors
NumberOfRecords??? = 0  ' Total number of records in the current database
        Index$ = "" ' Name of current index if open
       IndexField$ = "" ' Name of current indexed field if index open
       IndexField? = 0  ' Field number of current indexed field if ...

'=========================================================================
'                         Test program goes here
'=========================================================================



'=========================================================================
'         dBASE III Plus file interface subroutines begin here
'=========================================================================
SUB dBSetIndexTo(IX$,Fld$,e%)
e%=0
' Make sure a database is open
IF dBASEOpen%=0 THEN e%=1:EXIT SUB

' close existing index if it is open
IF IX$="" OR Index$<>"" THEN Index$="":_
   CALL BT("","Q","","","","",r%)
IF IX$="" THEN EXIT SUB
' verify filename exists
IF DIR$(IX$)="" THEN e%=3:EXIT SUB

' verify field exists in database
Fld%=0:Fld$=UCASE$(Fld$)
    FOR y%=1 TO NumberOfFields?
            IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
    NEXT y%
IF Fld%=0 THEN e%=2:EXIT SUB
Index$=IX$:IndexField$=Fld$:IndexField?=Fld%
END SUB

SUB dBCreateIndex(IX$, Fld$, e%)
Bt.Update.Always%=0
' Make sure a database is open
IF dBASEOpen%=0 THEN e%=1:GOTO ExitSub

' close existing index if it is open
IF IX$="" OR Index$<>"" THEN Index$="":_
   CALL BT("","Q","","","","",r%)
IF IX$="" THEN EXIT SUB

' verify field exists in database
Fld%=0:Fld$=UCASE$(Fld$)
    FOR y%=1 TO NumberOfFields?
            IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
    NEXT y%
IF Fld%=0 THEN e%=2:GOTO EXITSUB
Index$=IX$:IndexField$=Fld$:IndexField?=Fld%

' Create the index and build it.
K$=SPACE$(DBS(Fld%).FieldLength):D$=CHR$(0,0,0,0)
CALL BT(Index$,"C",K$,D$,RK$,RD$,R%)
IF NOT R% THEN E%=3:GOTO EXITSUB ' could not create index
x%=CSRLIN:y%=POS(0)
For y???=1 TO NumberOfRecords???
    dBGetRecord Y???, e%
        IF e% THEN e%=4:EXIT FOR
    IF INSTAT THEN A$=INKEY$:IF A$=CHR$(27) THEN e%=5:EXIT FOR

        ' ====================
        ' remove the UCASE$ here if you do not want the index to be
        ' create as case insensative.
        K$=UCASE$(dBGetCField$(Indexfield$, e%))
        '  ^^^^^^____________________________ ^

        IF e% THEN e%=6:EXIT FOR
        D$=MKDWD$(Y???)  ' must know the record number!
    CALL BT(Index$,"A",K$,D$,RK$,RD$,r%)
        IF NOT r% THEN e%=7:EXIT FOR
        LOCATE x%,y%:PRINT Y???;
        NEXT y???
    CALL BT(Index$,"Q","","","","",r%)
ExitSub:
        SELECT CASE e%
        CASE 1
                PRINT "No database in USE."
        CASE 2
                PRINT "Field name not found."
        CASE 3
                PRINT "Could not create file."
                CASE 4
                PRINT "Invalid record number."
        CASE 5
                PRINT "**ABORTED**"
        CASE 6
                PRINT "Error finding field data."
            CASE 7
                PRINT "Error writing to index file."
                CASE ELSE
            PRINT
        END SELECT
BT.Update.Always%=-1
END SUB

SUB dBSearchIndex(Findme$,e%)
e%=0
IF dBaseOpen%=0 THEN e%=1:EXIT SUB
IF Index$="" THEN
        INPUT "Index not open, scan database? (Y/N): ",YN$
    IF UCASE$(YN$)="Y" THEN
        ' scan the whole database for a match
        FOR y???=1 TO NumberOfRecords???
                dBGetRecord y???, e%
                    IF e% THEN EXIT FOR
                    IF INSTR(FindMe$,RecordBlock$) THEN EXIT FOR
        NEXT y???
        IF y???=>NumberOfRecords THEN _
                print "Last Record.  Press a key...":DO:LOOP WHILE INKEY$=""
        END IF
ELSE
        Findme$=UCASE$(Findme$)
    CALL BT(Index$,"S", Findme$, D$, RK$, RD$, r%)
        'IF NOT r% THEN e%=2:EXIT SUB
        FindMe$=RK$
        R???=CVDWD(RD$)
        IF R???>0 THEN CALL dBGetRecord(R???,e%)
END IF
END SUB

SUB dBSkip(NS%, e%)
e%=0
IF LEN(INDEX$) THEN
        DO
    IF NS%<0 THEN BT Index$,"P","","",K$,D$,r%:INCR NS% ELSE _
                      BT Index$,"N","","",K$,D$,r%:DECR NS%
        IF NOT r% THEN e%=1:EXIT SUB
        IF INSTAT THEN IF A$=CHR$(27) THEN NS%=0
        LOOP WHILE NS%<>0
        dBGetRecord CVDWD(D$), e%
ELSE
    RN???=RecNum??? + NS%
        IF RN???<0 THEN RN???=1
        IF RN??? > NumberOfRecords??? THEN RN???=NumberOfRecords???
        dBGetRecord RN???,e%
END IF
END SUB

SUB dBGotoTop (e%)
e%=0
IF LEN(INDEX$) THEN
    BT Index$,"F","","",K$,D$,r%
        IF NOT r% THEN e%=-2:EXIT SUB
        DBGetRecord CVDWD(D$),e%
ELSE
    DBGetRecord 1, e%
END IF
END SUB

SUB dBGotoBottom (e%)
e%=0
IF LEN(INDEX$) THEN
    BT Index$,"L","","",K$,D$,r%
        IF NOT r% THEN e%=-2:EXIT SUB
        DBGetRecord CVDWD(D$),e%
ELSE
    DBGetRecord NumberOfRecords???, e%
END IF
END SUB

SUB dBEditRecord (RN???, e%)
e%=0
    dBGetRecord RN???, e%
        IF e% THEN EXIT SUB

' remove entry from index
IF LEN(INDEX$) THEN
    BT Index$,"D",UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
    IF NOT r% THEN PRINT "Error accessing index file"
END IF

        ' edit the record
        DBEditFields e%

' replace entry in index
IF LEN(INDEX$) THEN
    BT Index$,"A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
    IF NOT r% THEN PRINT "Error updating index file"
END IF
END SUB

SUB dBAppendRecord (e%)
    e%=0
        IF dBaseOpen%=0 THEN e%=1:EXIT SUB
    Recnum???=0
        RecordBlock$=SPACE$(LEN(RecordBlock$))
    DbEditFields e%
    IF Recnum???>0 AND LEN(INDEX$) THEN
            BT Index$, "A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RecNum???),"","",r%
                IF NOT r% THEN PRINT "Error appending index file."
        END IF
END SUB

SUB dBDefaultFormat
' Create a default field edit format.
IF dBaseOpen%=0 THEN EXIT SUB
ERASE DBE()
k%=1
FOR y%=1 to NumberOfFields?
        INCR j%:IF j%=20 THEN j%=1:k%=k%+40:IF K%=81 THEN EXIT FOR
    DBE(y%).FieldName = DBS(y%).FieldName
        DBE(y%).FieldType = DBS(y%).FieldType
        DBE(y%).FieldLength = DBS(y%).FieldLength
        DBE(y%).FieldRow = j%
        DBE(y%).FieldCol = k%+(11-LEN(RTRIM$(DBS(y%).FieldName,CHR$(0))))
    DBE(y%).FieldFG = 0
        DBE(y%).FieldBG = 7
NEXT y%
END SUB

SUB dBCreateFormat
IF dBaseOpen%=0 THEN PRINT "No Database is in USE.":EXIT SUB
DO
CLS
DBView
LOCATE 23,1:COLOR 7,0:INPUT "Press ENTER to Accept or Fieldname to change: ",F$
IF F$="" THEN
    B%=FREEFILE
        LOCATE 23,1:PRINT SPACE$(80);
        LOCATE 23,1:INPUT "Enter format filename: ",F$
        IF F$="" THEN F$="NONAME.FMT"
        OPEN F$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
        Fld%=1
        DO UNTIL DBE(Fld%).FieldLength=0
            PUT #B%, Fld%, DBE(Fld%)
                INCR Fld%
        LOOP
        EXIT LOOP
ELSE
Fld%=0
F$=UCASE$(F$)
    FOR y%=1 TO NumberOfFields?
            IF INSTR(DBS(y%).FieldName,F$)=1 THEN Fld%=y%:EXIT FOR
    NEXT y%
IF Fld%=0 THEN LOCATE 23,1:PRINT SPACE$(80):LOCATE 23,1:PRINT "BAD FIELD NAME":SOUND 50,4:DELAY 2:ITERATE LOOP
LOCATE 23,1:PRINT SPACE$(80);:LOCATE 23,1:PRINT "Use arrow keys to place new field position"
X%=DBE(Fld%).FieldRow
Y%=DBE(Fld%).FieldCol
F$=RTRIM$(DBE(Fld%).FieldName,CHR$(0))+":"+STRING$(DBE(Fld%).FieldLength,176)
' edit field location
DBSCRNFIND X%, Y%, F$
IF X%=0 THEN EXIT LOOP
DBE(Fld%).FieldRow = X%
DBE(Fld%).FieldCol = Y%
END IF
LOOP
END SUB

SUB dBSetFormatTo(FormatFileName$,Ecode%)
Ecode%=0
IF FormatFileName$="" THEN ERASE DBE():EXIT SUB
IF Dir$(FormatFileName$)="" THEN Ecode%=1:EXIT SUB
B%=FREEFILE
OPEN FormatFileName$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
FOR y%=1 TO LOF(B%)\LEN(DBE)
    GET #B%, y%, DBE(y%)
NEXT y%
CLOSE #B%
END SUB

SUB dBView
Fld%=1
of%=(PBVScrnTxtAttr AND &HF) ' get the original foreground and background
ob%=(PBVScrnTxtAttr \ &H10)  ' colors, in case they change.
DO UNTIL DBE(Fld%).FieldLength=0
    LOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol,0
        COLOR of%,ob%
        PRINT RTRIM$(DBE(Fld%).FieldName,chr$(0))+":";
        r%=CSRLIN:c%=POS(0)
        COLOR DBE(Fld%).FieldFG,DBE(Fld%).FieldBG
        PRINT SPACE$(DBE(Fld%).FieldLength)
    LOCATE r%,c%:
        IF DBE(Fld%).FieldType="N" THEN
            PRINT dBGetNField!((DBE(Fld%).FieldName),E%);
                IF E% THEN PRINT "???";
    ELSE
            PRINT dBGetCField$((DBE(Fld%).FieldName),E%);
                IF E% THEN PRINT "???";
    END IF
    INCR Fld%
LOOP
COLOR of%, ob%
END SUB


SUB dBEditFields(Ecode%)
Ecode%=0
Fld%=1 ' start with the first field on the screen
of%=(PBVScrnTxtAttr AND &HF) ' get the original foreground and background
ob%=(PBVScrnTxtAttr \ &H10)  ' colors, in case they change.
' Now make one pass and DRAW the fields on the screen with defaults
DO UNTIL DBE(Fld%).FieldLength=0
    LOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol,0
        COLOR of%,ob%
        PRINT RTRIM$(DBE(Fld%).FieldName,chr$(0))+":";
        r%=CSRLIN:c%=POS(0)
        COLOR DBE(Fld%).FieldFG,DBE(Fld%).FieldBG
        PRINT SPACE$(DBE(Fld%).FieldLength)
    LOCATE r%,c%:
        IF DBE(Fld%).FieldType="N" THEN
            PRINT dBGetNField!((DBE(Fld%).FieldName),E%);
                IF E% THEN PRINT "???";
    ELSE
            PRINT dBGetCField$((DBE(Fld%).FieldName),E%);
                IF E% THEN PRINT "???";
    END IF

    INCR Fld%
LOOP


Fld%=1 ' start with the first field on the screen
' Now go back and edit the fields
DO UNTIL DBE(Fld%).FieldLength=0
    LOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol,0
        COLOR of%,ob%
        PRINT RTRIM$(DBE(Fld%).FieldName,CHR$(0))+":";
        r%=CSRLIN:c%=POS(0)
        IF DBE(Fld%).FieldType="N" THEN
                num%=-1
            ED$=STR$(dBGetNField!((DBE(Fld%).FieldName),E%))
                IF E% THEN ED$="???"
                    ELSE
                num%=0
            ED$= dBGetCField$((DBE(Fld%).FieldName),E%)
                IF E% THEN ED$="???"
    END IF

        ED$=DBGET$(r%, c%, (DBE(Fld%).FieldLength), (DBE(Fld%).FieldFG),_
                  (DBE(Fld%).FieldBG), ED$, -1, num%,KeyFlag%)

        IF num% THEN
            dBPutNField (DBE(Fld%).FieldName), VAL(ED$), E%
        ELSE
            dBPutCField (DBE(Fld%).FieldName),ED$,E%
    END IF

    SELECT CASE KeyFlag%
            CASE 10
                    DBPutRecord RecNum???, E%
                        EXIT LOOP
        CASE 5
                    EXIT LOOP
        CASE 0,2,6
                    INCR Fld%
                        IF Fld%>NumberOfFields? THEN Fld%=NumberOfFields?
                CASE 4,8
                    DECR Fld%
                        IF Fld%=0 THEN Fld%=1
        END SELECT
LOOP
Color Of%, Ob%

END SUB



SUB dBPutCField(FieldName$, FieldData$, Ecode%)
Ecode% = 1
    FieldName$=UCASE$(FieldName$)
FOR nof? = 1 TO NumberOfFields?
    IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
                IF LEN(FieldData$)>DBS(nof?).FieldLength THEN FieldData$=LEFT$(FieldData$,DBS(nof?).FieldLength)
        MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
        DBS(nof?).FieldLength) = FieldData$ + _
                Space$(DBS(nof?).FieldLength-LEN(FieldData$))
        Ecode% = 0
        EXIT FOR
    END IF
NEXT nof?
END SUB

SUB dBPutNField(FieldName$, FieldData!, Ecode%)
    Ecode% = 1
    FieldName$=UCASE$(FieldName$)

FOR nof? = 1 TO NumberOfFields?
    IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
    Pattern$ = STRING$(DBS(nof?).FieldLength,"#")
    IF DBS(nof?).FieldDecimals > 0 THEN
    MID$(Pattern$,LEN(Pattern$)-(DBS(nof?).FieldDecimals),1)="."
    END IF
    FieldData$ = USING$(Pattern$,FieldData!)
    MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
    DBS(nof?).FieldLength) = FieldData$
        Ecode% = 0
        EXIT FOR
    END IF
NEXT nof?

END SUB


SUB dBPutRecord(RN???,Ecode%)
Ecode% = 0
IF dBaseOpen% = 0 THEN Ecode% = 1: Exit Sub
                         ' Error Code 1 = Database file not open
GET #dBaseOpen%, 1, DBH
IF RN??? > DBH.NumberOfRecords + 1 THEN RN???=0
IF RN???<1 OR RN???=DBH.NumberOfRecords+1 THEN RN???=DBH.NumberOfRecords+1 :_
 DBH.NumberOfRecords = RN???:LastRec%=1: NumberOfRecords???=RN???
R$=MID$(RecordBlock$,2)
IF LEN(R$)<DBH.Size+1 THEN R$=R$+SPACE$(DBH.Size+1-LEN(R$))
IF LastRec%=1 THEN R$=R$+CHR$(26)
PUT #dBaseOpen%, DBH.offset + ((RN??? * DBH.Size) - DBH.Size)+1 , R$
IF DBH.NumberOfRecords = RN??? THEN _
          e$ = CHR$(26) + CHR$(10): PUT #dBaseOpen%, SEEK(dBaseOpen%) + 1, e$
DBH.Day   = VAL(MID$(DATE$, 4, 2))
DBH.Month = VAL(LEFT$(DATE$, 2))
DBH.Year  = VAL(RIGHT$(DATE$, 2))

PUT #dBaseOpen%, 1, DBH

END SUB


SUB dBGetARRAY(DB$(),Ecode%)

IF UBOUND(DB$()) < NumberOfFields? THEN Ecode% = 1:EXIT SUB
                    ' Error code 1, array not big enough
FOR nof? = 1 TO NumberOfFields?
    IF INSTR("CLD",DBS(nof?).FieldType) THEN
        DB$(nof?) = MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
        DBS(nof?).FieldLength)
    ELSE
        DB$(nof?) = STR$(val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
     DBS(nof?).FieldLength)) * (10 ^ DBS(nof?).FieldDecimals))
    END IF
NEXT nof?
END SUB



FUNCTION dBGetASCII$
A$=""
FOR nof? = 1 TO NumberOfFields?
    IF INSTR("CLD",DBS(nof?).FieldType) THEN
        A$ = A$ + CHR$(34)+MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
        DBS(nof?).FieldLength)+CHR$(34)
    ELSE
        A$ = A$ + STR$(val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
     DBS(nof?).FieldLength)) * (10 ^ DBS(nof?).FieldDecimals))
    END IF
    IF nof? < NumberOfFields? THEN A$ = A$ + ","
NEXT nof?
dBGetASCII$ = A$
END FUNCTION




FUNCTION dBGetCField$ (FieldName$, Ecode%)
Ecode% = 1
    FieldName$=UCASE$(FieldName$)
FOR nof? = 1 TO NumberOfFields?
    IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
        dBGetCField$ = MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
        DBS(nof?).FieldLength)
        Ecode% = 0
        EXIT FOR
    END IF
NEXT nof?
END FUNCTION

FUNCTION dBGetNField!(FieldName$,Ecode%)
    Ecode% = 1
    FieldName$=UCASE$(FieldName$)
FOR nof? = 1 TO NumberOfFields?
    IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
    dBGetNField! = val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
     DBS(nof?).FieldLength)) '* (10 ^ -DBS(nof?).FieldDecimals)
        Ecode% = 0
        EXIT FOR
    END IF
NEXT nof?

END FUNCTION


SUB DBGetRecord (Rn???, Ecode%)
Ecode% = 0
IF dBaseOpen% = 0 THEN Ecode% = 1: EXIT SUB              ' database not open
GET #dBaseOpen%, 1, DBH
IF Rn??? > DBH.NumberOfRecords THEN Ecode% = 2: EXIT SUB   ' record too high
IF Rn??? < 1 THEN Ecode% = 2: EXIT SUB                     ' record too low

SEEK #dBaseOpen%, DBH.offset + (Rn??? * DBH.Size) - DBH.Size
GET$ dBaseOpen%, DBH.Size + 2, RecordBlock$
RecNum???=RN???
END SUB  ' dBGetRecord



SUB dBUse (FileName$, Ecode%)
Ecode% = 0: Recnum??? = 0
IF dBaseOpen% THEN CLOSE #dBaseOpen%: dBaseOpen% = 0
                                  'if database file is open, then close it.
FileName$ = UCASE$(FileName$)
IF INSTR(FileName$, ".") = 0 THEN FileName$ = FileName$ + ".DBF"
IF DIR$(FileName$) = "" THEN Ecode% = 1: EXIT SUB
                                                  ' error 1=file not found

LET dBaseOpen% = 81
OPEN FileName$ FOR BINARY ACCESS READ WRITE SHARED AS #dBaseOpen%
IF LOF(dBaseOpen%) = 0 THEN CLOSE #dBaseOpen%:dBaseOpen%=0:Ecode%=2:EXIT SUB
                                                ' Error 2=file is 0 length

GET #dBaseOpen%, 1, DBH
IF DBH.Year > 99 OR DBH.Month > 12 OR DBH.Month = 0 OR_
   DBH.Day > 31 OR DBH.Day = 0 THEN CLOSE #dBaseOpen%:_
   dBaseOpen% = 0: Ecode% = 4: EXIT SUB
                                              ' Error 4 = not a dBASE file

' establish number of fields by (dbh.offset-len(dbheader))\32
NumberOfRecords??? = DBH.NumberOfRecords
NumberOfFields? = (DBH.offset - LEN(DBH)) \ 32
IF NumberOfFields?<1 THEN Ecode% = 3:CLOSE #dBaseOpen%:dBaseOpen%=0:Exit SUB
                                ' Error 3 = no fields in database structure


' Load the field definition header
DBS(1).FieldOffset = 3
FOR nof? = 1 TO NumberOfFields?
    GET #dBaseOpen%, SEEK(dBaseOpen%), DBF

        DBS(nof?).FieldName     = DBF.FieldName
        DBS(nof?).FieldType     = DBF.FieldType
        DBS(nof?).FieldLength   = DBF.FLen
        DBS(nof?+1).FieldOffset = DBS(nof?).FieldOffset + DBF.FLen
        DBS(nof?).FieldDecimals = DBF.DecC
NEXT nof?
CALL dBDefaultFormat  ' set default screen format
RecordBlock$=SPACE$(DBH.Size+2)
END SUB 'dBUse


FUNCTION DBGET$(y%,x%,length%,fg%,bg%,whole$,ins%,num%,keyflag%)
LOCAL tscan%, exitflag%, curpos%, tempwhole$, first%
  ofg%=(PBVSCRNTXTATTR AND &HF)
  ofb%=PBVSCRNTXTATTR / &H10
  keyflag% = 0
  tempwhole$ = whole$
  first% = %TRUE
  LOCATE y%,x% : COLOR fg%,bg% : PRINT SPACE$(length%)
  exitflag% = %FALSE
  curpos% = 0

  DO
    IF ins% THEN tscan% = %INSERTSCAN ELSE tascn% = %OVERWRITESCAN
    LOCATE y%,x% : PRINT whole$+SPACE$(length%-LEN(whole$))
    LOCATE y%,x%+curpos%,1,tscan%,7

    ky$ = GETKEY$("")
    IF ky$ < CHR$(31) THEN first% = %FALSE
    SELECT CASE ky$
      CASE > CHR$(31)
        IF num% THEN
          IF ky$ > CHR$(62) THEN EXIT SELECT
        END IF
        IF first% THEN
          whole$ = ky$
          curpos% = 1
          first% = %FALSE
          EXIT SELECT
        END IF
        IF ins% THEN
          IF curpos% < LEN(whole$) THEN
            whole$ = RTRIM$(whole$)
            IF LEN(whole$) < length% THEN
              whole$ = LEFT$(whole$,curpos%)+ky$+RIGHT$(whole$,LEN(whole$)-curpos%)
              INCR curpos%,1
              IF curpos% = length% THEN DECR curpos%,1
            END IF
          ELSE
            whole$ = whole$ + ky$
            INCR curpos%,1
            IF curpos% = length% THEN DECR curpos%,1
          END IF
        ELSE
          IF curpos% < LEN(whole$) THEN
            MID$(whole$,curpos%+1) = ky$
          ELSE
            whole$ = whole$ + ky$
          END IF
          INCR curpos%,1
          IF curpos% = length% THEN DECR curpos%,1
        END IF
      CASE CHR$(0,75)'**** LEFT ****
        IF curpos% <> 0 THEN DECR curpos%,1
      CASE CHR$(0,77)'**** RIGHT ****
        IF curpos% <> length%-1 THEN INCR curpos%,1
        IF curpos% > LEN(whole$) THEN whole$=whole$+" "
      CASE CHR$(0,71)'**** HOME ****
        curpos% = 0
      CASE CHR$(0,79)'**** END ****
           whole$ = RTRIM$(whole$)
           curpos% = LEN(whole$)
           IF LEN(whole$) = length% THEN DECR curpos%,1
      CASE CHR$(0,82)'**** INS ****
        ins% = NOT ins%
        IF tscan% = 3 THEN tscan% = 6 ELSE tscan% = 3
      CASE CHR$(0,83)'**** DEL ****
        IF curpos% > LEN(whole$)-1 THEN EXIT SELECT
        whole$ = LEFT$(whole$,curpos%) + RIGHT$(whole$,LEN(whole$)-curpos%-1)
      CASE CHR$(8)'**** BACKSPACE ****
        IF curpos% <> 0 THEN
          whole$ = LEFT$(whole$,curpos%-1) + RIGHT$(whole$,LEN(whole$)-curpos%)
          DECR curpos%,1
        END IF
      CASE CHR$(13)'**** ENTER ****
        exitflag% = %TRUE
        keyflag% = 0
      CASE CHR$(27)'**** ESC ****
        exitflag% = %TRUE
        keyflag% = 5
        whole$ = tempwhole$
      CASE CHR$(0,72)'**** UP ARROW ****
        exitflag% = %TRUE
        keyflag% = 8
      CASE CHR$(0,80)'**** DOWN ARROW ****
        exitflag% = %TRUE
        keyflag% = 2
      CASE CHR$(9)'**** TAB ****
        exitflag% = %TRUE
        keyflag% = 6
      CASE CHR$(0,15)'**** SHFT-TAB ****
        exitflag% = %TRUE
        keyflag% = 4
          CASE CHR$(0,117),CHR$(0,68)
              exitflag%=%TRUE
                keyflag%=10

    END SELECT

  LOOP UNTIL exitflag%
  COLOR ofg%, obg%
  DBGET$ = RTRIM$(whole$)

END FUNCTION

FUNCTION getkey$(mstr$)
  IF mstr$ = "" THEN
    DO
      k$ = INKEY$
    LOOP UNTIL k$ <> ""
  ELSE
    DO
      k$ = INKEY$
    LOOP UNTIL INSTR(k$,ANY mstr$)
  END IF
  getkey$ = k$
END FUNCTION

SUB DBSCRNFIND(X%, Y%, F$)
'arrows around F$ on the screen. and returns the ultimate coordinates.
REG 1, 15*256
CALL INTERRUPT &H10
IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
DEF SEG = ADDRESS
O$=PEEK$(0,4000)

DO   ' a deer, a female deer
    LOCATE X%, Y%:COLOR 20,0:PRINT F$;
        COLOR 7,0
        LOCATE 23,1:PRINT SPACE$(80);
        LOCATE 23,1:PRINT "Use arrows to re-position field.  ENTER finishes, ESC aborts.";
    KB$="" : WHILE KB$=""    ' create a polling loop instead of SLEEPing
                KB$=INKEY$
        WEND
        POKE$ 0,O$
        SELECT CASE KB$

            CASE CHR$(0,71) '  home
                            Y%=1
            CASE CHR$(0,72) '  up arrow
                            DECR X%:IF X%=0 THEN X%=22
            CASE CHR$(0,73) '  page up
                            X%=1
            CASE CHR$(0,75) '  left arrow
                            DECR Y%:IF Y%=0 THEN Y%=79-LEN(F$)
            CASE CHR$(0,77) '  right arrow
                            INCR Y%:IF Y%>79-LEN(F$) THEN Y%=1
            CASE CHR$(0,79) '  end
                            Y%=79-LEN(F$)
            CASE CHR$(0,80) '  down arrow
                            INCR X%:IF X%=23 THEN X%=1
            CASE CHR$(0,81) '  page down
                            X%=22
            CASE CHR$(0,82) '  Insert
            CASE CHR$(0,83) '  Delete
            CASE CHR$(0,59) '  f1
            CASE CHR$(0,60) '  f2
            CASE CHR$(0,61) '  f3
            CASE CHR$(0,62) '  f4
            CASE CHR$(0,63) '  f5
            CASE CHR$(0,64) '  f6
            CASE CHR$(0,65) '  f7
            CASE CHR$(0,66) '  f8
            CASE CHR$(0,67) '  f9
            CASE CHR$(0,68) '  f10
                            FINISHED=-1
            CASE CHR$(0,115) ' CTL-Left arrow
                            Y%=Y%-8:IF Y%<1 THEN Y%=1
            CASE CHR$(0,116) ' CTL-Right arrow
                            Y%=Y%+8:IF Y%>79-LEN(F$) THEN y%=79-LEN(F$)
            CASE CHR$(0,117) ' CTL-END
                            FINISHED=-1
            CASE CHR$(0,118) ' CTL-PgDn
            CASE CHR$(0,119) ' CTL-HOME
                            X%=1:Y%=1
            CASE CHR$(0,132) ' CTL-PgUp
            CASE CHR$(3)  '  CTL-C ETX
                            X%=0:FINISHED=-1
            CASE CHR$(9)  '  CTL-I TAB
                            Y%=Y%+8:IF Y%>79-LEN(F$) THEN y%=79-LEN(F$)
            CASE CHR$(13)  ' CTL-M CARRIAGE RETURN
                            FINISHED=-1
            CASE CHR$(16)  ' CTL-P DLE
            CASE CHR$(21)  ' CTL-U NAK
            CASE CHR$(27)  ' Escape ESC
                            X%=0:FINISHED=-1

            END SELECT


LOOP WHILE NOT FINISHED
POKE$ 0, O$
DEF SEG

END SUB


$INCLUDE "BTREE.BAS"