[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]