Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DBBROW20.ZIP/DBFINFO.PAS

Pascal/Delphi Source File | 1988-07-03 | 7.3 KB | 257 lines

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.