Category : Pascal Source Code
Archive   : DBASEIII.ZIP
Filename : DBASEIII.PAS

 
Output of file : DBASEIII.PAS contained in archive : DBASEIII.ZIP

unit dbaseiii;
{ unit including procedures for accessing DBaseIII files}

interface

uses Crt;

Procedure OpenDBFData;
Procedure OpenDBFMemo;
Procedure ReadDBFRecord(I : Longint);
Procedure WriteDBFRecord;
Procedure ReadDBFMemo(BlockNumber : integer);
Procedure WriteDBFMemo(var BlockNumberString : string);
Procedure CloseDBFData;
Procedure CloseDBFMemo;

const
DBFMaxRecordLength = 4096;
DBFMemoBlockLength = 512;
DBFMaxMemoLength = 4096;

type
DBFHeaderRec = Record
HeadType : byte;
Year : byte;
Month : byte;
Day : byte;
RecordCount : longint;
HeaderLength : integer;
RecordSize : integer;
Garbage : array[1..20] of byte;
end;

type
DBFFieldRec = Record
FieldName : array[1..11] of char;
FieldType : char;
Spare1,
Spare2 : integer;
Width : byte;
Dec : byte;
WorkSpace : array[1..14] of byte;
end;

var
DBFFileName : string;

DBFDataFile : File;
DBFDataFileAvailable : boolean;
DBFBuffer : array [1..DBFMaxRecordLength] of char;

DBFHeading : DBFHeaderRec;

DBFField : DBFFieldRec;
DBFFieldCount : integer;
DBFFieldContent : array [1..128] of string;

DBFNames : array [1..128] of string[10];
DBFLengths : array [1..128] of byte;
DBFTypes : array [1..128] of char;
DBFDecimals : array [1..128] of byte;
DBFContentStart : array [1..128] of integer;

DBFMemoFile : File;
DBFMemoFileAvailable : boolean;
DBFMemoBuffer : Array [1..DBFMemoBlockLength] of byte;
DBFMemo : Array [1..DBFMaxMemoLength] of char;

DBFMemoLength : integer;
DBFMemoEnd : boolean;
DBFMemoBlock : integer;

DBFDeleteField : char;
DBFFieldStart : integer;

DBFRecordNumber : longint;

(****************************************************************)

implementation

(****************************************************************)

Procedure ReadDBFHeader;

var
RecordsRead : integer;

begin
BlockRead (DBFDataFile, DBFHeading, SizeOf(DBFHeading), RecordsRead);
end;

(*****************************************************************)

Procedure ProcessField (F : DBFFieldRec;
I : integer);
var
J : integer;

begin
with F do
begin
DBFNames [I] := '';
J := 1;
while (J<11) and (FieldName[J] <> #0) do
begin
DBFNames[I] := DBFNames[I] + FieldName [J];
J := J + 1;
end;
DBFLengths [I] := Width;
DBFTypes [I] := FieldType;
DBFDecimals [I] := Dec;
DBFContentStart [I] := DBFFieldStart;
DBFFieldStart := DBFFieldStart + Width;
end;
end;

(***************************************************************)

Procedure ReadFields;

var
I : integer;
RecordsRead : integer;

begin
Seek(DBFDataFile,32);
I := 1;
DBFFieldStart := 2;
DBFField.FieldName[1] := ' ';
while (DBFField.FieldName[1] <> #13) do
begin
BlockRead(DBFDataFile,DBFField.FieldName[1],1);
if (DBFField.FieldName[1] <> #13) then
begin
BlockRead(DBFDataFile, DBFField.FieldName[2],SizeOf(DBFField) - 1, RecordsRead);
ProcessField (DBFField, I);
I := I + 1;
end;
end;
DBFFieldCount := I - 1;
end;

(***********************************************************)

Procedure OpenDBFData;

begin
DBFDataFileAvailable := false;
Assign(DBFDataFile, DBFFileName+'.DBF');

{$I-}
Reset(DBFDataFile,1);
If IOResult<>0 then exit;
{$I+}

DBFDataFileAvailable := true;
Seek(DBFDataFile,0);
ReadDBFHeader;
ReadFields;
end;

(******************************************************************)

Procedure CloseDBFData;

begin
if DBFDataFileAvailable then Close(DBFDataFile);
end;

(*******************************************************************)

Procedure OpenDBFMemo;

begin
DBFMemoFileAvailable := false;
Assign(DBFMemoFile, DBFFileName+'.DBT');

{$I-}
Reset(DBFMemoFile,1);
If IOResult<>0 then exit;
{$I+}

DBFMemoFileAvailable := true;
Seek(DBFMemoFile,0);
end;

(*******************************************************************)

Procedure CloseDBFMemo;

begin
If DBFMemoFileAvailable then close(DBFMemoFile);
end;

(*******************************************************************)

Procedure GetDBFFields;

var
I : byte;
J : integer;
Response : string;

begin
DBFDeleteField := DBFBuffer[1];
For I:=1 to DBFFieldCount do
begin
DBFFieldContent[I] := '';
For J := DBFContentStart[I] to DBFContentStart [I] + DBFLengths[I] -1 do
DBFFieldContent[I] := DBFFieldContent[I] + DBFBuffer[J];
For J := 1 to DBFLengths[I] do
if DBFFieldContent[J]=#0 then DBFFieldContent[J]:=#32;
end;
end;

(***********************************************************************)

Procedure ReadDBFRecord (I : Longint);

var
RecordsRead : integer;

begin
Seek(DBFDataFile, DBFHeading.HeaderLength + DBFHeading.RecordSize * (I - 1));
BlockRead (DBFDataFile, DBFBuffer, DBFHeading.RecordSize, RecordsRead);
GetDBFFields;
end;

(**********************************************************************)


Procedure ReadDBFMemo(BlockNumber : integer);

var
I : integer;
RecordsRead : word;

begin
DBFMemoLength := 0;
DBFMemoEnd := false;
If not DBFMemoFileAvailable then
begin
DBFMemoEnd := true;
exit;
end;
FillChar(DBFMemo[1],DBFMaxMemoLength,#0);
Seek(DBFMemoFile,BlockNumber*DBFMemoBlockLength);
repeat
BlockRead(DBFMemoFile,DBFMemoBuffer,DBFMemoBlockLength,RecordsRead);
For I := 1 to RecordsRead do
begin
DBFMemoLength := DBFMemoLength + 1;
DBFMemo[DBFMemoLength] := chr(DBFMemoBuffer[I] and $7F);
If (DBFMemoBuffer[I] = $1A) or (DBFMemoBuffer[I] = $00) then
begin
DBFMemoEnd := true;
DBFMemoLength := DBFMemoLength - 1;
exit;
end;
end;
until DBFMemoEnd;
end;

(*********************************************************************)

Procedure WriteDBFMemo {(var BlockNumberString : string)};

var
K : integer;
ReturnCode : integer;

begin
Val(BlockNumberString,DBFMemoBlock,ReturnCode);
If ReturnCode>0 then DBFMemoBlock := 0;
If DBFMemoBlock>0 then
begin
Writeln;
ReadDBFMemo(DBFMemoBlock);
If DBFMemoLength=0 then exit;
For K := 1 to DBFMemoLength do
Write(DBFMemo[K]);
WriteLn;
end;
end;

(****************************************************************)

Procedure WriteDBFRecord;

var
J : byte;

begin
For J := 1 to DBFFieldCount do
begin
Write(DBFNames[J]);
GoToXY(12,J);
WriteLn(DBFFieldContent[J]);
if DBFTypes[J]='M' then WriteDBFMemo(DBFFieldContent[J]);
end;
end;

(*******************************************************************)

begin
end.