DEFINT A-Z

DECLARE FUNCTION ReadDbfHdr% ()
DECLARE FUNCTION ReadFileStructure% ()
DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)

DECLARE SUB DspDbfInfo ()
DECLARE SUB InputRecord (R$())
DECLARE SUB Pause ()
DECLARE SUB WriteRecord (R$(), AppendingRecordFlag%)

'=================================================
'=   PROGRAM: WriteDBF.BAS                       =
'=   PURPOSE: Write records to dBASE III+/IV     =
'=            DBF files                          =
'=================================================

'-------------------------------------------------
' Initialize variables and create types          -
'-------------------------------------------------

CONST True = -1, False = 0

TYPE HeaderInfoType
  VersionNumber AS INTEGER
  LastUpdate    AS STRING * 8
  NumberRecords AS LONG
  HeaderLength  AS INTEGER
  RecordLength  AS INTEGER
  NumberFields  AS INTEGER
  FileSize      AS LONG
END TYPE

TYPE FieldInfoType
  FdName   AS STRING * 11
  FdType   AS STRING * 1
  FdLength AS INTEGER
  FdDec    AS INTEGER
END TYPE

DIM SHARED Hdr AS HeaderInfoType
DIM SHARED FileName$

'-------------------------------------------------
'  Main processing loop                          -
'-------------------------------------------------

  FileName$ = "PLANETS.DBF"
  OPEN FileName$ FOR BINARY AS #1
  CLS
  ActionHdr = ReadDbfHdr
  SELECT CASE ActionHdr
    CASE 1
      BEEP
      PRINT "Not a dBASE III+ or IV file"
    CASE ELSE
      DspDbfInfo
      Pause
      DIM SHARED Flds(Hdr.NumberFields) AS FieldInfoType
      ActionFile = ReadFileStructure
      SELECT CASE ActionFile
        CASE True
          DIM SHARED NewData$(Hdr.NumberFields)
          Response$ = ""
          RecNbr = Hdr.NumberRecords
          DO WHILE UCASE$(Response$) <> "N"
            CLS
            INPUT "Append record to file (Y/N)"; Response$
            IF UCASE$(Response$) = "Y" THEN
              RecNbr = RecNbr + 1 'Append Record
              CALL InputRecord(NewData$())
              CALL WriteRecord(NewData$(), RecNbr)
              ActionHdr = ReadDbfHdr
              DspDbfInfo
              Pause
            END IF
          LOOP
        CASE False
          BEEP
          PRINT "Field information error"
      END SELECT
   END SELECT
   PRINT "DBF closed"
   CLOSE #1
   END

SUB DspDbfInfo
  
'-------------------------------------------------
'Display dBASE file header information           -
'-------------------------------------------------

PRINT USING "dBASE Version         : #"; Hdr.VersionNumber
PRINT "Database in use       : "; FileName$
PRINT USING "Number of data records: ########"; Hdr.NumberRecords
PRINT "Date of last update   : "; Hdr.LastUpdate
PRINT USING "Header length         :     ####"; Hdr.HeaderLength
PRINT USING "Record length         :     ####"; Hdr.RecordLength
PRINT USING "Number of fields      :      ###"; Hdr.NumberFields
PRINT USING "File size             : ########"; Hdr.FileSize

END SUB

SUB InputRecord (R$())
'-------------------------------------------------
'Prompt user to input all fields for a record    -
'-------------------------------------------------

CLS

LOCATE 1, 35: PRINT "Enter Records": PRINT

PRINT "Field Name    Type                Length";
PRINT "  Decimals  - Enter Value"
PRINT
Fmt1$ = "\        \   \                \"
Fmt2$ = "    ###      ##       <"
FOR I = 1 TO UBOUND(R$)

  IF Flds(I).FdType <> "M" THEN
    ExtraOffset = 0
    SELECT CASE Flds(I).FdType
      CASE "C"
        PromptType$ = "Character"
      CASE "N"
        PromptType$ = "Numeric"
      CASE "F"
        PromptType$ = "Floating Point"
      CASE "L"
        PromptType$ = "Logical"
      CASE "D"
        PromptType$ = "Date (YYYY/MM/DD)"
        ExtraOffset = 2
      CASE ELSE
    END SELECT

    PRINT USING Fmt1$; Flds(I).FdName; PromptType$;
    PRINT USING Fmt2$; Flds(I).FdLength; Flds(I).FdDec;

    PRINT SPACE$(Flds(I).FdLength + ExtraOffset); ">";
    LOCATE , POS(0) - Flds(I).FdLength - 1 - ExtraOffset
    INPUT "", R$(I)
  END IF
NEXT I
END SUB

SUB Pause

'-------------------------------------------------
'Prompt user to press a key to continue          -
'-------------------------------------------------

  PRINT
  PRINT "Press any key to continue"
  WHILE INKEY$ = "": WEND
END SUB

FUNCTION ReadDbfHdr

'-------------------------------------------------
'Purpose: Read the dBASE file header information -
'         and store in the header record         -                                        -
'-------------------------------------------------

HdrStr$ = SPACE$(32)
GET #1, 1, HdrStr$              'Read dBASE Header

Hdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7)

UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1)))
UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1)))
UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1)))

Hdr.LastUpdate = UpdMM$ + "/" + UpdDD$ + "/" + UpdYY$

Hdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4))
Hdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2))
Hdr.RecordLength = CVI(MID$(HdrStr$, 11, 2))

Hdr.NumberFields = (Hdr.HeaderLength - 33) / 32
DataSize = Hdr.RecordLength * Hdr.NumberRecords + 1
Hdr.FileSize = Hdr.HeaderLength + DataSize

IF Hdr.VersionNumber <> 3 THEN
   ReadDbfHdr = 1                'Not a dBASE file
   EXIT FUNCTION
END IF

IF Hdr.NumberRecords = 0 THEN
   ReadDbfHdr = 2                'No records
   EXIT FUNCTION
END IF
ReadDbfHdr = 0                   'No errors
END FUNCTION

FUNCTION ReadFileStructure
  
'-------------------------------------------------
'Purpose: Read the file structure store in the   -
'         dBASE file header.                     -
'-------------------------------------------------

FOR I = 1 TO Hdr.NumberFields
   Fld$ = SPACE$(32)
   GET #1, , Fld$           'Get field info string
   Flds(I).FdName = LEFT$(Fld$, 11)
   Flds(I).FdType = MID$(Fld$, 12, 1)
   Flds(I).FdLength = ASC(MID$(Fld$, 17, 1))
   Flds(I).FdDec = ASC(MID$(Fld$, 18, 1))
NEXT I
HeaderTerminator$ = INPUT$(1, #1)   'Last hdr byte
IF ASC(HeaderTerminator$) <> 13 THEN
   ReadFileStructure = False       'Bad Dbf header
END IF
ReadFileStructure = True
END FUNCTION

FUNCTION RightJust$ (Value$, FldWidth)
  
'-------------------------------------------------
'Purpose: Right justify a string by padding it   -
'         with spaces on the left                -
'Input  : The character value to justify, the    -
'         width of the field to fit              -
'Output : A right justified string to print      -
'-------------------------------------------------

RightJust$ = RIGHT$(STRING$(FldWidth, " ") + Value$, FldWidth)
END FUNCTION

SUB WriteRecord (R$(), RecNbr)

'-------------------------------------------------
'Purpose: Write record to DBF file               -
'Input  : String array of field contents, R$()   -
'         Record number to write, RecNbr         -
'         Appends record to file if greater than -
'         number of records currently in file    -
'-------------------------------------------------

  IF RecNbr > Hdr.NumberRecords THEN 'Appending rec
    Offset = (Hdr.NumberRecords) * Hdr.RecordLength
    RecPos = Offset + Hdr.HeaderLength + 1
    Hdr.NumberRecords = Hdr.NumberRecords + 1
    NR$ = MKL$(Hdr.NumberRecords)
    PUT #1, 5, NR$
    Appending = True
  ELSE
    Offset = (RecNbr - 1) * Hdr.RecordLength
    RecPos = Offset + Hdr.HeaderLength + 1
    Appending = False
  END IF

  EOFchr$ = CHR$(26)  'Set End of File character

  R$(0) = " " 'Init to 1 space for the status flag
  PUT #1, RecPos, R$(0)

  FOR I = 1 TO UBOUND(R$)

    IF Flds(I).FdType = "D" THEN
      R$(I) = LEFT$(R$(I), 4) + MID$(R$(I), 6, 2)
      R$(I) = R$(I) + RIGHT$(R$(I), 2)
    END IF
    'If Larger than field width
    IF LEN(R$(I)) > Flds(I).FdLength THEN
      R$(I) = LEFT$(R$(I), Flds(I).FdLength)
    ELSEIF LEN(R$(I)) < Flds(I).FdLength THEN
      IF INSTR("NF", Flds(I).FdType) <> 0 THEN
        ' Right justify numbers
        R$(I) = RightJust$(R$(I), Flds(I).FdLength)
      ELSE
        'Else left justify all other field types
        R$(I) = R$(I) + SPACE$(Flds(I).FdLength - LEN(R$(I)))
      END IF
    END IF

    PUT #1, , R$(I)

  NEXT I


  IF Appending THEN 'Add End of record marker
    PUT #1, , EOFchr$
  END IF

  D$ = DATE$
  UpdYY$ = CHR$(VAL(RIGHT$(D$, 2)))
  PUT #1, 2, UpdYY$
  UpdMM$ = CHR$(VAL(LEFT$(D$, 2)))
  PUT #1, 3, UpdMM$
  UpdDD$ = CHR$(VAL(MID$(D$, 4, 2)))
  PUT #1, 4, UpdDD$
  PRINT : PRINT "Record written and file updated"
  PRINT
END SUB

DEFSNG A-Z
FUNCTION ZeroJust$ (Number AS INTEGER)
  
'-------------------------------------------------
'Purpose: Add a leading zero to numbers less     -
'         than 10 so they take as much room as   -
'         numbers 10 and larger                  -
'Input  : The number to standardize              -
'Output : The adjusted number                    -
'-------------------------------------------------

N$ = STR$(Number)
LengthN = LEN(N$) - 1'Subtract 1 for leading space
N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2)
ZeroJust$ = N$
END FUNCTION