[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]

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.

[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]