Category : Pascal Source Code
Archive   : DBF4PAS.ZIP
Filename : DEMO4.PAS

 
Output of file : DEMO4.PAS contained in archive : DBF4PAS.ZIP
{ This is a short demo of the DBF unit. I didn't have time to make this }
{ readable. So you can see what I had to go through with this guy's code! }

program DBF_Demo;

uses crt,dbf;
var
d : dbfrecord;

PROCEDURE ErrorHalt(errorCode : Integer);
VAR
errorMsg : _Str80;
BEGIN
CASE errorCode OF
00 : Exit; { no error occurred }
$01 : errorMsg := 'Not found';
$02 : errorMsg := 'Not open for input';
$03 : errorMsg := 'Not open for output';
$04 : errorMsg := 'Just not open';
$91 : errorMsg := 'Seek beyond EOF';
$99 : errorMsg := 'Unexpected EOF';
$F0 : errorMsg := 'Disk write error';
$F1 : errorMsg := 'Directory full';
$F3 : errorMsg := 'Too many files';
$FF : errorMsg := 'Where did that file go?';
NOT_DB_FILE : errorMsg := 'Not a dBASE data file';
INVALID_FIELD : errorMsg := 'Invalid field type encountered';
REC_TOO_HIGH : errorMsg := 'Requested record beyond range';
PARTIAL_READ : errorMsg := 'Tried to read beyon EOF';
ELSE
errorMsg := 'Undefined error';
END;
WriteLn;
WriteLn(errorCode:3, ': ',errorMsg);
Halt(1);
END;

TYPE
PseudoStr = ARRAY[1..255] OF Char;
VAR
Demo : dbfRecord;
j, i : Integer;
blanks : _Str255;
SizeOfFile, r : longint;
fn : _Str64;

PROCEDURE Wait;
VAR
c : Char;
BEGIN
Write('Press any key to continue . . .');
repeat
c := readkey
until c <> #0
END;


PROCEDURE List(VAR D : dbfRecord);

PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);
VAR
Data : PseudoStr ABSOLUTE a;
BEGIN
WITH F DO
BEGIN
CASE Typ OF
'C', 'N', 'L' : Write(Copy(Data, 1, Len));
'M' : Write('Memo ');
'D' : Write(Copy(Data, 5, 2), '/',
Copy(Data, 7, 2), '/',
Copy(Data, 1, 2));
END; {CASE}
IF Len <= Length(Name) THEN
Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
ELSE
Write(' ');
END; {WITH F}
END; {ShowField}

BEGIN {List}
WriteLn;
Write('Rec Num ');
WITH D DO
BEGIN
FOR i := 1 TO NumFields DO
WITH Fields^[i] DO
IF Len >= Length(Name) THEN
Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
ELSE
Write(Name, ' ');
WriteLn;
r := 1;
WHILE r <= NumRecs DO
BEGIN
GetDbfRecord(Demo, r);
IF NOT dbfOK THEN ErrorHalt(dbfError);
WriteLn;
Write(r:7, ' ');
Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
FOR i := 1 TO NumFields DO
ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
r := r+1;
END; {WHILE r }
END; {WITH D }
END; {List}

PROCEDURE DisplayStructure(VAR D : dbfRecord);
VAR
i : Integer;
BEGIN
WITH D DO
BEGIN
ClrScr;
Write(' # Field Name Type Length Decimal');
FOR i := 1 TO NumFields DO
BEGIN
WITH Fields^[i] DO
BEGIN
IF i MOD 20 = 0 THEN
BEGIN
WriteLn;
Wait;
ClrScr;
Write(' # Field Name Type Length Decimal');
END;
GoToXY(1, Succ(WhereY));
Write(i:2, Name:12, Typ:5, Len:9);
IF Typ = 'N' THEN Write(Dec:5);
END; {WITH Fields^}
END; {FOR}
WriteLn;
Wait;
END; {WITH D}
END; { DisplayStructure }

BEGIN
WITH Demo DO
BEGIN
FillChar(blanks, SizeOf(blanks), $20);
blanks[0] := Chr(255);
ClrScr;
GoToXY(10, 10);
Write('Name of dBASE file (.DBF assumed): ');
Read(FileName);
IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
OpenDbf(Demo);
IF NOT dbfOK THEN ErrorHalt(dbfError);
ClrScr;
SizeOfFile := FileSize(dFile);
WriteLn('File Name: ', FileName);
WriteLn('Date Of Last Update: ', DateOfUpdate);
WriteLn('Number of Records: ', NumRecs:10);
WriteLn('Size of File: ', SizeOfFile:15);
WriteLn('Length of Header: ', HeadLen:11);
WriteLn('Length of One Record: ', RecLen:7);
IF WithMemo THEN WriteLn('This file contains Memo fields.');
IF HeadProlog[0] = DB2File THEN WriteLn('dBASE 2.4 file');
Wait;
ClrScr;
DisplayStructure(Demo);
ClrScr;
List(Demo);
WriteLn;
Wait;
CloseDbf(Demo);
IF NOT dbfOK THEN ErrorHalt(dbfError);
END;
END.


  3 Responses to “Category : Pascal Source Code
Archive   : DBF4PAS.ZIP
Filename : DEMO4.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/