'                            Program  : DBREADER
'                            Author   : Keith Farrell
'                            Language : QuickBASIC 4.5
'                            AIM      : to read the header information
'                                       of a standard dBase file - ie
'                                       not comma delimited ( qv SEQREAD )
'                                       Header types covered will be
'                                       dBII, dBIII, dBIII Plus, DBIV
'                                       at present only the dbIII plus, I
'                                       don't think header changed with
'                                       the plus - and four is assumed
'                                       to be the same except for the ID
'                                       dBII reader not implemented - the
'                                       header structure is quite different.
'                                      The 'REAL' version of this program
'                                      is written in Modula - this is OK
'                                      to distribute as source code though

ON ERROR GOTO ErrorHandler
'     VARIABLES USED
'     ##############

DIM Field$(100)

COLOR 7, 12: CLS
COLOR 8, 10: LOCATE 2, 30: PRINT "Dbase file header reader"
LOCATE 25, 30: PRINT "V 0.5 (c) Keith Farrell 1991";
COLOR 7, 12

' File To Open :::::::
LOCATE 5, 10: FILES "*.DBF"
LOCATE 20, 10: PRINT "File to Open";
INPUT FileName$
FileName$ = FileName$ + ".DBF"
CLS
'     Open file and read first byte to decide which format
'     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

OPEN FileName$ FOR INPUT AS #1
PRINT : PRINT "File : "; FileName$; "  Type - ";
ProgID$ = INPUT$(1, #1)
IF ASC(ProgID$) = &H2 THEN PRINT "DB II" ' and goto DBII header section
IF ASC(ProgID$) = &H3 THEN PRINT "DB III"
IF ASC(ProgID$) = &H83 THEN PRINT "DB III with memo"
'
'     ~~~~~~~~~~~~~~~~~~~~~~~
'     Dbase III header reader
'     ~~~~~~~~~~~~~~~~~~~~~~~

'     Date last updated
'     ~~~~~~~~~~~~~~~~~~~~~~~

Year$ = INPUT$(1, #1)
Month$ = INPUT$(1, #1)
Day$ = INPUT$(1, #1)
PRINT "Updated       :  DDMMYY - ";
PRINT ASC(Day$); "/"; ASC(Month$); "/"; ASC(Year$)

'     Number of Records
'     ~~~~~~~~~~~~~~~~~~~~~~~

Length1$ = INPUT$(1, #1)
Length2$ = INPUT$(1, #1)
Length3$ = INPUT$(1, #1)
Length4$ = INPUT$(1, #1)
Length = (ASC(Length4$) * 16777216) + (ASC(Length3$) * 65536) + (ASC(Length2$) * 256) + ASC(Length1$)
PRINT "File Length   : "; Length; " records"

'     Size of Header in Bytes
'     ~~~~~~~~~~~~~~~~~~~~~~~

HLength1$ = INPUT$(1, #1)
Hlength2$ = INPUT$(1, #1)
HeadLength = ASC(Hlength2$) * 256 + ASC(HLength1$)
PRINT "Header Length : "; HeadLength

'     Size of Record in Bytes
'     ~~~~~~~~~~~~~~~~~~~~~~~

RLength1$ = INPUT$(1, #1)
RLength2$ = INPUT$(1, #1)
RecordLength = ASC(RLength2$) * 256 + ASC(RLength1$)
PRINT "Record Length : "; RecordLength
PRINT STRING$(30, 220)
'     Read Reserved - not used
'     ~~~~~~~~~~~~~~~~~~~~~~~~

RESERVED$ = INPUT$(20, #1)

'     Field Descriptions
'     ~~~~~~~~~~~~~~~~~~

Count = 1: CharCounter = 0: Blanks = 7: Column = 1: Offset = 40
      ScreenLine = Count + Blanks
WHILE Char <> 13
  Temp$ = INPUT$(1, #1)
  Char = ASC(Temp$)
  CharCounter = CharCounter + 1
  Built$ = Built$ + Temp$
    IF CharCounter = 11 THEN
      Field$(Count) = Built$
    END IF
    IF CharCounter = 12 THEN FType$ = Temp$
    IF CharCounter = 17 THEN FLength = Char
    IF CharCounter = 18 THEN DLength = Char
    IF CharCounter = 32 THEN
      CharCounter = 0
      Built$ = ""
        IF ScreenLine >= 24 THEN
          ScreenLine = ScreenLine - (24 - Blanks) + 1
          Column = Column + Offset
        END IF
      LOCATE ScreenLine, Column: PRINT "F"; Count; "- "; Field$(Count);
      LOCATE ScreenLine, Column + 20: PRINT FType$
      LOCATE ScreenLine, Column + 22: PRINT FLength
      IF DLength > 0 THEN LOCATE ScreenLine, Column + 26: PRINT DLength
      Count = Count + 1: ScreenLine = ScreenLine + 1
    END IF
WEND
CLOSE #1
LOCATE 25, 1: PRINT "";
END

ErrorHandler:
  PRINT "An error has occurred - "; ERR
    SELECT CASE ERR
           CASE IS = 53
               PRINT "There is no file by that name on this disk"
           CASE IS = 58
               PRINT "File already exists - reported when renaming as .BAK"
               PRINT "Do you wish to KILL it - and thus continue (Y/N)"
               Action$ = UCASE$(INPUT$(1))
                IF Action$ = "Y" THEN KILL Source$
           CASE ELSE
               PRINT "uh oh"
    END SELECT
   IF ERR = 53 OR (ERR = 58 AND Action$ = "N") THEN STOP
  PRINT
  PRINT , "tap a key to continue (unless the error was 'uh oh')"
  A$ = INPUT$(1)
RESUME NEXT