[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]

Unit dbfinfo;
interface
uses
        crt;

var
        dbfile : file;
        currentrec : longint;
        dbfilename : string;
        dbfileok : boolean;
        dberr : integer;


procedure dbwrthd;      {writes the header info}
procedure disprec;      {displays the record data}
procedure dbhdrd;       {reads the header info}
procedure waitforkey;   {waits for key to be hit}

implementation
const
     dbmaxflds = 128;   {max. number of fields }
     dbmaxrecsize = 4000; {max. size of a record }


Type

    DBfileinfo = record      { first 32 bytes of DBF }
        version : byte;
                year : byte;
        month : byte;
                day : byte;
                norecord : longint;
                headlen : integer;
                reclen : integer;
                res : array[1..20] of byte;
                end;

        DBfieldinfo = record            { 32 byte field info }
                name  : array[1..11] of char;
                ftype : byte;
                addr  : longint;
                len   : byte;
                dcnt  : byte;
                res   : array[1..14] of char;
                end;

        dbfldar = array[1..dbmaxflds] of dbfieldinfo;
        dbrecar = array[1..dbmaxrecsize] of char;

var
        dbhead : dbfileinfo;
        dbfield : dbfldar;
        dbnofld : integer;
        dbrecord : dbrecar;


procedure waitforkey;
var
        junk : char;
begin
        writeln;
        write('Hit any key to continue');
        junk := readkey;
end;


{ read rdbase III  header info }
{ blockread error - dberr = h = 0, l = number of records read}
{ bad header - dberr - h = 1, l = version }
procedure dbhdrd;
var
   i : integer;
begin
        blockread(dbfile,dbhead,32,dberr);
        dbfileok := (dberr = 32);
        dbnofld := (dbhead.headlen - 33) div 32;
        if not dbfileok then exit;

        if not ((dbhead.version = $83) or (dbhead.version = $03)) then
        begin
                dbfileok := false;
                dberr := dbhead.version or $100;
                exit;
        end;

        for i := 1 to dbnofld do
        begin
                blockread(dbfile,dbfield[i],32,dberr);
                dbfileok := (dberr = 32);
        if not dbfileok then exit;
    end;

end;

{ writes field titles on screen }
procedure dbwrfldtit(line : integer);
begin
        gotoxy(1,line);
        write('Field Name   Type  Len  Dec');
    gotoxy(40,line);
    writeln('Field Name   Type Len  Dec');
        write('-----------------------------------------------------------------');
end;


{ writes all header info to the screen }
procedure dbwrthd;
var
        line,j,i : integer;

begin
    clrscr;
    gotoxy(29,1);
    write('DBase file ',dbfilename);
    gotoxy(1,3);
    with dbhead do
    begin
        write('Last Time File Updated  - ',month:2,'/',day:2,'/',year:2);
                gotoxy(40,3);
                write('Number of records in file - ',norecord);
                gotoxy(1,4);
                write('Length of each record   - ',reclen);
                gotoxy(40,4);
        end;
        write('Number of fields          - ',dbnofld);
        dbwrfldtit(6);
        line := 8;
        for i := 1 to dbnofld do
        begin
        if odd(i) then gotoxy(1,line) else gotoxy(40,line);
                with dbfield[i] do
                begin
                        for j := 1 to 11 do write(name[j]);
                        write('    ',chr(ftype),'   ',len:3,' ',dcnt:3);
                end;
        if not odd(i) then
        begin
            line := succ(line);
            if line = 24 then
            begin
                 if i < dbnofld then
                 begin
                      line := 3;
                      writeln;
                      write('More ....');
                      waitforkey;
                      clrscr;
                      dbwrfldtit(1);
                      end;
                 end;
            end;
        end;
        waitforkey;
end;

{ read and display a DBase III record }
{ if field data is larger than one line if will be truncated }

procedure dbreadrec(rec : longint);
const
        maxchar = 65;   {maximum characters to display from record}
var
    temp : longint;
        i,j,stoppos,startpos,maxlen : integer;
        linecnt : integer;

begin
        with dbhead do
        begin
             if (rec < 1) or (rec > norecord) then
             begin
                  dberr := 0;
                  dbfileok := false;
                  exit;
             end;
             temp := rec;
             rec := (rec - 1) * reclen + headlen;
             seek(dbfile,rec);
             blockread(dbfile,dbrecord,reclen,dberr);
        end;
        clrscr;
        write('DBASE file ',dbfilename,'   Record No. ',temp);
        if dbrecord[1] = '*' then writeln('    DELETED') else writeln;
        writeln;
        startpos := 2;
        linecnt := 1;
        for i := 1 to dbnofld do
        begin
             with dbfield[i] do
             begin
                  for j := 1 to 11 do write(name[j]);
                  write(' -- ');
                  if len > maxchar then maxlen := maxchar
                  else maxlen := len;
                  stoppos := startpos + maxlen;
                  for j := startpos to stoppos -1 do write(dbrecord[j]);
                  startpos := startpos + len;
                  writeln;
                  linecnt := succ(linecnt);
                  if linecnt = 22 then
                  begin
                       if i < dbnofld then
                       begin
                            linecnt := 1;
                            write('More ....');
                            waitforkey;
                            for j := 3 to 25 do
                            begin
                                 gotoxy(1,j);
                                 clreol;
                            end;
                            gotoxy(1,3);
                       end;
                  end;
             end;
        end;
        waitforkey;
end;

procedure disprec;
var
        rec : string;
        treal : real;
        error : integer;

begin
        repeat
              clrscr;
              writeln('DBASE file -- ',dbfilename);
              writeln;
              write('Total records = ',dbhead.norecord);
              writeln('   Current Record = ',currentrec);
              writeln;
              write('Enter record to display (0 = exit, cr = next, - = previous)? ');
              readln(rec);
              if (rec = '') or (rec[1] = '-') then
              begin
                   if rec = '' then currentrec := succ(currentrec)
                   else
                   currentrec := pred(currentrec);
              end
              else
              begin
                   val(rec,treal,error);
                   if error <> 0 then treal := 0.0;
                   currentrec := trunc(treal);
              end;
              if currentrec = 0 then exit;
              if currentrec < 0 then currentrec := 1;
              if currentrec > dbhead.norecord then currentrec := dbhead.norecord;
              dbreadrec(currentrec);
        until false

end;
begin
end.

                       Dbase III DBF File Structure


Header
------


        
BYTE #                Type                Example           Description
------                ----            -------           -----------
        
0                Byte                   1              DBASE Version
                                                  (83H with DBT file)
                                                  (03H without DBT file)

1                Byte                   2                  Year - Binary

2                Byte                   3                  Month - Binary

3               Byte                   4                  Day - Binary

4-7                32 bit integer     5              Number of records in file

8-9                16 bit integer           6                  Length of header

10-11                16 bit integer     7                  Length of record

12-31                20 Bytes           8              Reserved

32-n                32 Bytes                          Field Descriptor
                                                  (See below)
                                        
n+1                Byte               9              0Dh field terminator

N+2                  Byte              10              00h In some older versions
                                                  (The length of header byte
                                                  reflects this if present)
.pa

Field Descriptor
----------------

BYTE #                Type                Example           Description
------                ----            -------           -----------

0-10                byte                   11             Field name 
                                                  (Zero filled)

11                Byte                   12                  Field Type
                                                  (N D L C M)

12-15                32 bit integer           13                  Field data address
                                                  (Internal use)

16                Byte                   14                  Field length - Binary

17                Byte                   15                  Field decimal count - Binary

18-31                14 bytes           16                  Reserved



Field Types
-----------


N        Numeric - 0 1 2 3 4 5 6 7 8 . -


D        Date - 8 Bytes (YYYYMMDD)


L        Logical - Y y N n T t F f ? (? = Not initialized)


C        Character - Any Ascii Character


M        Memo - 10 digits (DBT block Number)



Data Records
------------


        All data is in Ascii.


        There is no field seperators or record terminators.

        The first byte is a space (20h) if record not deleted and an
        asterick (2AH) if deleted.



DBASE Limitations
-----------------

Fields - 128 Max.

Record - 4000 bytes Max.

Header - 4130 bytes Max.

          (128 Fields * 32 bytes) + 32 bytes + 1 terminator + (1 null)

Number - 19 digits




Example File
------------


         1  2  3  4     5         6     7          8
        || || || || |---------| |---| |---| |---------- 
000000  83 55 0B 0E 31 00 00 00-81 01 89 00 00 00 00 00  .U..1...........

        ----------------------------------------------|
000010  00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00  ................

                      11                 12     13
        |------------------------------| || |---------| 
000020  46 49 52 53 54 4E 41 4D-45 00 00 43 13 01 9D 41  FIRSTNAME..C...A

        14 15                     16
        || || |---------------------------------------|
000030  14 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000040  4C 41 53 54 4E 41 4D 45-00 00 00 43 27 01 9D 41  LASTNAME...C'..A

000050  14 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000060  50 48 4F 4E 45 00 00 00-00 00 00 43 3B 01 9D 41  PHONE......C;..A

000070  0D 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000080  54 52 41 56 45 4C 43 4F-44 45 00 43 48 01 9D 41  TRAVELCODE.CH..A

000090  04 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

0000A0  54 52 41 56 45 4C 50 4C-41 4E 00 43 4C 01 9D 41  TRAVELPLAN.CL..A

0000B0  28 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  (...............

0000C0  44 45 50 41 52 54 55 52-45 00 00 44 74 01 9D 41  DEPARTURE..Dt..A

0000D0  08 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

0000E0  43 4F 53 54 00 50 41 49-44 00 00 4E 7C 01 9D 41  COST.PAID..N|..A

0000F0  0A 02 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000100  50 41 49 44 00 4F 54 45-53 00 00 4C 86 01 9D 41  PAID.OTES..L...A

000110  01 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000120  41 47 45 4E 54 00 00 00-00 00 00 43 87 01 9D 41  AGENT......C...A

000130  02 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000140  52 45 53 45 52 56 44 41-54 45 00 44 89 01 9D 41  RESERVDATE.D...A

000150  08 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

000160  4E 4F 54 45 53 00 00 00-00 00 00 4D 91 01 9D 41  NOTES......M...A

000170  0A 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00  ................

                Firstname
           || |----------------------------------------
000180  0D 20 43 6C 61 69 72 65-20 20 20 20 20 20 20 20  . Claire        
                           
                            Lastname
        ----------------| |----------------------------
000190  20 20 20 20 20 20 42 75-63 6B 6D 61 6E 20 20 20        Buckman   

                                        Phone
        ----------------------------| |----------------
0001A0  20 20 20 20 20 20 20 20-20 20 28 35 35 35 29 34            (555)4

                               T - code     T - plan
        -------------------| |---------| |-------------
0001B0  35 36 2D 39 30 35 39 43-49 31 30 31 30 2D 6E 69  56-9059CI1010-ni

        -----------------------------------------------
0001C0  67 68 74 20 43 61 72 69-62 62 65 61 6E 20 49 73  ght Caribbean Is

        -----------------------------------------------
0001D0  6C 61 6E 64 20 43 72 75-69 73 65 20 20 20 20 20  land Cruise     

                   Departure Date          Cost
        -------| |---------------------| |-------------                  
0001E0  20 20 20 31 39 38 35 31-30 32 34 20 20 20 31 31     19851024   11

                       PD  Age    Res. Date
        -------------| || |---| |---------------------|
0001F0  39 39 2E 30 30 54 4D 4D-31 39 38 35 30 37 31 35  99.00TMM19850715

.pa
            Notes
        |---------------------------|
000200  20 20 20 20 20 20 20 20-20 31 20 52 69 63 6B 20           1 Rick 

000210  20 20 20 20 20 20 20 20-20 20 20 20 20 20 20 4C                 L

000220  69 73 62 6F 6E 6E 20 20-20 20 20 20 20 20 20 20  isbonn          

000230  20 20 20 28 35 35 35 29-34 35 35 2D 33 33 34 34     (555)455-3344

000240  41 56 31 30 39 2D 6E 69-67 68 74 20 41 6C 61 73  AV109-night Alas

000250  6B 61 2F 56 61 6E 63 6F-75 76 65 72 20 43 72 75  ka/Vancouver Cru

000260  69 73 65 20 20 20 20 20-20 20 20 20 31 39 38 35  ise         1985

000270  30 38 30 35 20 20 20 31-33 37 38 2E 30 30 54 4A  0805   1378.00TJ

000280  54 31 39 38 35 30 37 31-35 20 20 20 20 20 20 20  T19850715       

000290  20 20 32 20 48 61 6E 6B-20 20 20 20 20 20 20 20    2 Hank


[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]