Contributor: SWAG SUPPORT TEAM
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 IOResult0 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 IOResult0 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 7ドルF);
If (DBFMemoBuffer[I] = 1ドルA) 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.