Category : Files from Magazines
Archive   : ITP9007.ZIP
Filename : DBASE.PAS

 
Output of file : DBASE.PAS contained in archive : ITP9007.ZIP
UNIT dBASE; {$R-}

INTERFACE

USES Crt;

TYPE

DbfFieldType = RECORD
FdName : String[10];
FdType : Char;
FdLength : Byte;
FdDec : Byte;
END;

DbfFieldTypeA = ARRAY[0..0] OF DbfFieldType;

DbfFileType = RECORD
VersionNumber : Byte;
Update : ARRAY [1..3] OF Byte;
NbrRec : Longint;
HdrLen : Integer;
RecLen : Word;
NbrFlds : Integer;
FileSize : Longint;
FileHndl : FILE;
FileName : String[12];
FieldStru : ^DbfFieldTypeA;
END;

DbfFile = ^DbfFileType;
CharArray = ARRAY[0..0] OF Char;
CharPtr = ^CharArray;

FUNCTION DbfOpen(FileName : String): DbfFile;
FUNCTION DbfClose(D: DbfFile): Boolean;
FUNCTION DbfReadHdr(D: DbfFile): Byte;
PROCEDURE DbfDispHdr(D: DbfFile);
PROCEDURE Pause;
FUNCTION DbfReadStru(D: DbfFile): Boolean;
PROCEDURE DbfDispStru(D: DbfFile);
PROCEDURE DbfReadRec (RecNum : Longint;
D: DbfFile; DbfPtr: CharPtr);
PROCEDURE DbfList(D: DbfFile);
PROCEDURE DbfDispRec(RecNum: Longint;
D: DbfFile; DbfPtr: CharPtr);

IMPLEMENTATION

PROCEDURE Tab(Col:Byte);
BEGIN
GotoXY(Col MOD 80,WhereY)
END;

FUNCTION DbfOpen(FileName : String): DbfFile;
VAR
D : DbfFile;
BEGIN
GetMem(D,SizeOf(DbfFileType));
D^.FileName := FileName;
Assign(D^.FileHndl, FileName);
Reset(D^.FileHndl,1); {Set record length to 1}
DbfOpen := D;
END;

FUNCTION DbfClose(D: DbfFile): Boolean;
BEGIN
Close(D^.FileHndl);
FreeMem(D^.FieldStru,
SizeOf(DbfFieldType)*(D^.NbrFlds+1));
FreeMem(D,SizeOf(DbfFileType));
DbfClose := TRUE
END;

FUNCTION DbfReadHdr(D: DbfFile): Byte;

{------------------------------------------------
Purpose: Read the Dbase file header information-
and store in the header record - -
-----------------------------------------------}

TYPE
DbfHdrMask = RECORD
VersionNumber : Byte;
Update : ARRAY [1..3] OF Byte;
NbrRec : Longint;
HdrLen : Integer;
RecLen : Integer;
Reserved : ARRAY [1..20] OF Char;
END;
VAR
Result : Word;
H : DbfHdrMask;
I : Byte;
BEGIN
BlockRead(D^.FileHndl, H, SizeOf(H), Result);
IF SizeOf(H) = Result THEN
BEGIN
WITH D^ DO
BEGIN
VersionNumber := H.VersionNumber AND 7;
FOR I := 1 TO 3 DO
Update[I] := H.Update[I];
NbrRec := H.NbrRec;
HdrLen := H.HdrLen;
RecLen := H.RecLen;
NbrFlds := (H.HdrLen - 33) DIV 32;
FileSize := H.HdrLen + H.RecLen
* H.NbrRec + 1;
DbfReadHdr := 0; {No errors }
IF VersionNumber <> 3 THEN
DbfReadHdr := 1 {Not a dBase file }
ELSE
IF NbrRec = 0 THEN
DbfReadHdr := 2 {No records }
END {WITH}
END {IF}
ELSE
DbfReadHdr := 3; {Error reading Dbf}
END; {FUNCTION}

PROCEDURE DbfDispHdr(D: DbfFile);

{------------------------------------------------
Display Dbase file header information -
------------------------------------------------}
BEGIN
WITH D^ DO
BEGIN
WriteLn('Using ',FileName); WriteLn;
WriteLn('dBASE Version :',
VersionNumber:8);
WriteLn('Number of data records:',
NbrRec:8);
Write('Date of last update : ');
WriteLn(Update[2]:2,'/',Update[3],
'/',Update[1]);
WriteLn('Header length :',HdrLen:8);
WriteLn('Record length :',RecLen:8);
WriteLn('Number of fields :',NbrFlds:8);
WriteLn('File size :',FileSize:8)
END
END;

PROCEDURE Pause;
BEGIN
WriteLn;
WriteLn('Press Enter to continue');
ReadLn;
END;

FUNCTION DbfReadStru(D: DbfFile): Boolean;

{------------------------------------------------
Purpose: Read the file structure store in the -
Dbase file header. -
------------------------------------------------}

TYPE
DbfFieldMask = RECORD
FdName : ARRAY [1..11] OF Char;
FdType : Char;
Reserved1 : ARRAY [1..4] OF Char;
FdLength : Byte;
FdDec : Byte;
Reserved2 : ARRAY [1..14] OF Char;
END;
VAR
Result : Word;
I, J, HdrTerminator : Byte;
FldTmp : DbfFieldMask;
BEGIN
GetMem(D^.FieldStru,
SizeOf(DbfFieldType)*(D^.NbrFlds+1));
WITH DbfFieldType(D^.FieldStru^[0]) DO
BEGIN {Set up record status field}
FdName := 'RecStatus ';
FdType := 'C';
FdLength := 1;
FdDec := 0
END;
FOR I := 1 TO D^.NbrFlds DO
BEGIN
BlockRead(D^.FileHndl,FldTmp,SizeOf(FldTmp),
Result);
WITH DbfFieldType(D^.FieldStru^[I]) DO
BEGIN
J := POS(#0,FldTmp.FdName);
IF J <> 0 THEN
FdName := Copy(FldTmp.FdName,1,J-1);
FdType := FldTmp.FdType;
FdLength := FldTmp.FdLength;
FdDec := FldTmp.FdDec
END
END;
{Last Hdr Byte}
BlockRead(D^.FileHndl,HdrTerminator,1,Result);
IF HdrTerminator <> 13 THEN
DbfReadStru := FALSE {Bad Dbf header}
ELSE
DbfReadStru := TRUE
END;

PROCEDURE DbfDispStru(D: DbfFile);

{-------------------------------------------------
Purpose: Display the structure of the Dbase file-
Name, Field Type, Length and number -
of decimals if a number -
------------------------------------------------}

VAR
Ty : String[11];
I : Byte;
BEGIN
WriteLn;

WriteLn(
'Field Field Name Type Width Dec');

FOR I := 1 TO D^.NbrFlds DO
BEGIN
WITH DbfFieldType(D^.FieldStru^[I]) DO
BEGIN
Write(I:5,' ',FdName);Tab(20);
CASE FdType OF
'C': Ty := 'Character ';
'L': Ty := 'Logical ';
'N': Ty := 'Number ';
'F': Ty := 'Floating Pt';
'D': Ty := 'Date ';
'M': Ty := 'Memo ';
ELSE Ty := 'Unknown '
END;
WriteLn(Ty:11,' ',FdLength:3,' ',
FdDec:2)
END;
END;
Write(' ** Total **'); Tab(32);
WriteLn(D^.RecLen:4)
END;

PROCEDURE DbfReadRec (RecNum : Longint;
D: DbfFile; DbfPtr: CharPtr);

{------------------------------------------------
Purpose: Read a Dbase record, format date and -
logical fields for output -
Input : Array of Field values -
-----------------------------------------------}

VAR
Result : Word;
CurrentPos : Longint;
BEGIN
CurrentPos := (RecNum-1) * D^.RecLen+D^.HdrLen;
Seek(D^.FileHndl,CurrentPos);
BlockRead(D^.FileHndl,DbfPtr^,D^.RecLen,Result)
END;

PROCEDURE DbfDispRec(RecNum: Longint;
D: DbfFile; DbfPtr: CharPtr);
VAR
Field : String;
I,J : Integer;
FPos : Byte;
SCol,ColumnSpace : Byte;
BEGIN
Write(RecNum:3,' ');
FPos := 0; {Record offset from pointer DbfPtr}
FOR I := 0 TO D^.NbrFlds DO
BEGIN
WITH D^.FieldStru^[I] DO
BEGIN
Field := '';
Move(DbfPtr^[FPos],Field[1],
Integer(FdLength));
Field[0] := Chr(FdLength);
CASE FdType OF {Adjust field types}
'D' : Field := Copy(Field,5,2) + '/' +
Copy(Field,7,2) + '/' +
Copy(Field,1,4);
'L' : CASE Field[1] OF
'Y','T' : Field := '.T.';
'N','F' : Field := '.F.';
END;
ELSE
END;
IF FdType <> 'M' THEN
Write(Field:FdLength,' ');
FPos := FPos + FdLength {Set next fld}
END
END;
WriteLn;
END;

PROCEDURE DbfList(D: DbfFile);

{------------------------------------------------
Purpose: Main printing routine -
Calls : ReadDbfRecord -
PrintDbfRecord -
-----------------------------------------------}
VAR
I : Longint; {Made a longint for seek request}
DbfPtr : CharPtr;
BEGIN
WriteLn;
FOR I := 1 TO D^.NbrRec DO
BEGIN
GetMem(DbfPtr, D^.RecLen);
DbfReadRec(I, D, DbfPtr);
DbfDispRec(I, D, DbfPtr);
FreeMem(DbfPtr, D^.RecLen);
END
END;

END.


  3 Responses to “Category : Files from Magazines
Archive   : ITP9007.ZIP
Filename : DBASE.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/