home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
insidetp
/
1990_07
/
dbase.pas
next >
Wrap
Pascal/Delphi Source File
|
1990-06-28
|
9KB
|
319 lines
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.