'       DBASE III COMPATIBLE DATA FILE INTERFACE for PowerBASIC 3.0+
'                       Public Domain by Erik Olson
' 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 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

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


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

SHARED DBH, DBF, DBS(), dBaseOpen%, RecNum???, NumberOfFields?, RecordBlock$
SHARED NumberOfRecords???

' THE FOLLOWING VARIABLES ARE SHARED AND CONTAIN USEFUL STATUS INFORMATION

	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

'=========================================================================
'                  dBASE INTERFACE PROGRAM GOES HERE
'=========================================================================






'=========================================================================
SUB dBPutCField(FieldName$, FieldData$, Ecode%)
Ecode% = 1
	FieldName$=UCASE$(FieldName$)
FOR nof? = 1 TO NumberOfFields?
	IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN

		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
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$

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?

END SUB 'dBUse