'---------------------------------------------------------

DEFINT A-Z
DECLARE FUNCTION ReadFileStructure% ()
DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
DECLARE FUNCTION ReadDbfHdr% ()
DECLARE SUB DspDbfInfo ()
DECLARE SUB DspFileStructure ()
DECLARE SUB Pause ()
DECLARE SUB PrintDbfRecord (fv$(), RecNum%)
DECLARE SUB PrintReport ()
DECLARE SUB ReadDbfRecord (fv$())

'=================================================
'=   PROGRAM: PRINTDBF.BAS                       =
'=   PURPOSE: Print listings of 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$

FileName$ = "PLANETS.DBF"

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

   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
               CLS
               DspFileStructure
               Pause
               IF ActionHdr <> 2 THEN
                  CLS
                  PrintReport
                  Pause
               ELSE
                  CLS
                  PRINT "No records to print"
               END IF
            CASE False
               BEEP
               PRINT "Field information error"
            END SELECT
   END SELECT
   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 DspFileStructure

'-------------------------------------------------
'Purpose: Display the structure of the dBASE file-
'         Name, Field Type, Length and number    -
'         of decimals if a number                -
'-------------------------------------------------

FieldTitleS$ = "Field  Field Name  Type        Width     Dec"
FieldString1$ = "  ###  \         \ "
FieldString2$ = "\         \   ###      ##"

PRINT : PRINT FieldTitleS$

FOR I = 1 TO Hdr.NumberFields
   PRINT USING FieldString1$; I; FLDS(I).FdName;
   SELECT CASE FLDS(I).FdType
      CASE "C": ty$ = "Character"
      CASE "L": ty$ = "Logical"
      CASE "N": ty$ = "Number"
      CASE "F": ty$ = "Floating Pt"
      CASE "D": ty$ = "Date"
      CASE "M": ty$ = "Memo"
      CASE ELSE: ty$ = "Unknown"
   END SELECT
   PRINT USING FieldString2$; ty$; FLDS(I).FdLength; FLDS(I).FdDec
NEXT I
PRINT "   ** Total **"; TAB(33);
PRINT USING "####"; Hdr.RecordLength

END SUB

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

SUB PrintDbfRecord (fv$(), RecNum)

'-------------------------------------------------
'Purpose: Print the record to the screen.  Left  -
'         justify character, date and logical    -
'         fields.  Right justify numeric fields  -
'         and ignore memo fields                 -
'Input  : Field values store in character array, -
'         current record number                  -
'-------------------------------------------------

' Print rec # & delete status
ColumnSpace = 4              'Room between columns
PRINT USING "####### !"; RecNum; fv$(0);

ColumnLocation = 10          'Set current location
FOR I = 1 TO Hdr.NumberFields
  IF FLDS(I).FdType <> "M" THEN
    PRINT TAB(ColumnLocation);
    IF FLDS(I).FdType = "N" OR FLDS(I).FdType = "F" THEN
      PRINT RightJust$(fv$(I), FLDS(I).FdLength);
    ELSE
      PRINT fv$(I);
    END IF
'       Set next print location
    ColumnLocation = ColumnLocation + FLDS(I).FdLength + ColumnSpace
  END IF
NEXT I
PRINT

END SUB

SUB PrintReport

'-------------------------------------------------
'Purpose: Main printing routine                  -
'Calls  : ReadDbfRecord                          -
'         PrintDbfRecord                         -
'-------------------------------------------------

DIM FieldValues$(Hdr.NumberFields)
PRINT : PRINT
PRINT "Report on the "; FileName$; " file"
PRINT
FOR I = 1 TO Hdr.NumberRecords
   CALL ReadDbfRecord(FieldValues$())
   CALL PrintDbfRecord(FieldValues$(), I)
NEXT I
END SUB

FUNCTION ReadDbfHdr

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

HdrStr$ = SPACE$(32)
GET #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
Hdr.FileSize = Hdr.HeaderLength + Hdr.RecordLength * Hdr.NumberRecords + 1

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

SUB ReadDbfRecord (fv$())

'-------------------------------------------------
'Purpose: Read a dBASE record, format date and   -
'         logical fields for output              -
'Input  : Array of Field values                  -
'-------------------------------------------------

F$ = SPACE$(Hdr.RecordLength)
GET #1, , F$                      'Read the record

fv$(0) = LEFT$(F$, 1)    'Read deleted record mark
FPOS = 2

FOR I = 1 TO Hdr.NumberFields

   fv$(I) = MID$(F$, FPOS, FLDS(I).FdLength)

   SELECT CASE FLDS(I).FdType  'Adjust field types
      CASE "D"                 'Modify date format
         y$ = LEFT$(fv$(I), 4)
         M$ = MID$(fv$(I), 5, 2)
         d$ = RIGHT$(fv$(I), 2)
         fv$(I) = M$ + "/" + d$ + "/" + y$
      CASE "L"                 'Standardize T or F
          SELECT CASE UCASE$(fv$(I))
             CASE "Y", "T": fv$(I) = ".T."
             CASE "N", "F": fv$(I) = ".F."
             CASE ELSE: fv$(I) = ".?."
          END SELECT
      CASE ELSE
   END SELECT
   FPOS = FPOS + FLDS(I).FdLength 'Set next fld
'   PRINT fv$(I)

NEXT I
END SUB

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$, FieldWidth)

'-------------------------------------------------
'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$(FieldWidth, " ") + Value$, FieldWidth)
END FUNCTION

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