New account

Unit: dBase  Bottom

  • Hello

    I have write a unit to read and write a DBF-File (Version III, III+, IV):

    Code

    Unit uDBase;

    // Unit fuer DBase III



    Interface



    Uses uStream, uSysInfo,

    uString, SysUtils;



    Const MaxFields = 127; // Von 0 bis 127



    type tDBaseFieldTyp = (tDBaseFT_Char,

    tDBaseFT_Numeric,

    tDBaseFT_Logical,

    tDBaseFT_Date,

    tDBaseFT_Memo);



    tDBaseVersion = (tDBaseVer_III, // DBase-Version III(+)

    tDBaseVer_IV); // DBase-Version IV





    type tcDBaseHeaderField = class

    private

    fName : tStr11;

    fTyp : tDBaseFieldTyp;

    fLength : LongWord;

    fDecimal: LongWord;

    public

    Constructor Create(Const iName : tStr11; Const iTyp : tDBaseFieldTyp;

    Const iLength : LongWord; Const iDecimal : LongWord); virtual;

    Property Name : tStr11 Read fName;

    Property Typ : tDBaseFieldTyp Read fTyp;

    Property Length : LongWord Read fLength;

    Property Decimal: LongWord Read fDecimal;

    end;



    type tArrDBaseHeaderFields = Array[0..MaxFields] of tcDBaseHeaderField;

    tArrDBaseHeaderFieldPos= Array[0..MaxFields] of LongWord;





    type tcDBaseDBT = class

    private

    fVersion : tDBaseVersion; // Version der DBase-Datei

    fFileName : tFileName; // Name der Memo-Datei

    fFileStream : tFileStream; // Stream-Objekt

    fBlockSize : LongWord;

    fBlockBuffer: pByteArray;

    fNextFreeRec: LongInt; // Naechster freie Block



    Procedure ReadMemoryHeader;

    Function ReadMemoryText(iBlockID : LongWord) : AnsiString;

    public

    Constructor Create(Const iFileName : tFileName; iVersion : tDBaseVersion); virtual;

    Destructor Destroy; override;



    Property FileName : tFileName Read fFileName;

    Property BlockSize: LongWord Read fBlockSize;

    end;



    type tcDBase = class

    private

    fVersion : tDBaseVersion; // Version der DBase-Datei

    fFileName : tFilename; // Name der Datenbank

    fFileStream : tFileStream; // Stream-Objekt

    fDBaseDBT : tcDBaseDBT; // Objekt fuer die DBT-Datei



    fHeaderSize : LongWord; // Groesse der Headerinformation

    fRecordCount : LongWord; // Anzahl der Saetze

    fRecordSize : Word; // Laenge des Datensatzes

    fFilePosFieldDef: LongWord; // Zeigt auf das 1. Feld in der Datei

    fFilePosData : LongWord; // Zeigt auf den 1. Satz in der Datei



    fFieldCount : LongWord; // Anzahl der Felder

    fHeaderFieldMod : Boolean; // =true...Header darf noch veraendert werden

    fHeaderFields : tArrDBaseHeaderFields;

    fHeaderFieldsPos: tArrDBaseHeaderFieldPos;



    fRow : LongWord;



    fRecordBuffer : PByteArray;

    fRecordDeleted : Boolean;



    fMemoryNextFreeRecord: LongWord;



    Procedure WriteHeader;

    Procedure ReadHeader;

    Procedure WriteFields;

    Procedure ReadFields;



    Procedure SetRow(iRow : LongWord);

    Procedure SetRecordDeleted(iDeleted : Boolean);



    Function getData(iFieldPos : LongWord) : Variant;

    Procedure setData(iFieldPos : LongWord; iData : Variant);



    Function CalcFilePosition : LongInt;

    public

    Procedure AddField(iName : tStr10; iTyp : tDBaseFieldTyp;

    iLength, iDecimal : Byte);

    Procedure AppendBlank;

    Procedure Update;



    Constructor Create(Const iFileName : tFileName); virtual;

    Destructor Destroy; override;



    Property FileName : tFileName Read fFileName;

    Property Version : tDBaseVersion Read fVersion;

    Property Row : LongWord Read fRow Write SetRow;

    Property FieldCount : LongWord Read fFieldCount;

    Property Fields : tArrDBaseHeaderFields Read fHeaderFields;



    Property HeaderFieldMod: Boolean Read fHeaderFieldMod;



    Property RecordCount : LongWord Read fRecordCount;

    Property RecordSize : Word Read fRecordSize;

    Property RecordDeleted : Boolean Read fRecordDeleted Write SetRecordDeleted;



    Property Data[FieldPos: LongWord]: Variant Read getData Write SetData;

    end;



    Implementation



    // Konstanten

    Const DBaseVersionDBII = ; // DBase II-Datei

    DBaseVersionDBIII = ; // DBase III/IV/FoxBase+/FoxPro 2x-Datei ohne Memofeld

    DBaseVersionDBIIIM = ; // DBase III-Datei mit Memofeld

    DBaseVersionDBIVM = B; // DBase IV-Datei mit MemoFeld

    DBaseVersionFoxPro2 = $F5; // FoxPro-Version 2.x mit Memo

    DBaseVersionFoxPro3 = ; // Visual-FoxPor 3.0

    fmOpen = fmOpenReadWrite Or fmShareDenyWrite;





    Const DBaseFieldType_Char = 'C';

    DBaseFieldType_Numeric_1 = 'N';

    DBaseFieldType_Numeric_2 = 'F';

    DBaseFieldType_Logical = 'L';

    DBaseFieldType_Date = 'D';

    DBaseFieldType_Memo = 'M';



    // Header-Definition

    type tDBFHeader = Record

    Version : Byte; // Version von der DBase-Datei

    WriteDate : Record // Letztes Datum des Schreibens

    Year : Byte; // Format: YY

    Month : Byte; // Format: MM

    Day : Byte; // Format: DD

    End;

    RecCount : LongWord; // Zahl der Datensaetze

    HeaderSize : Word; // Anzahl der Bytes von dem Header + Felddefinition

    RecordSize : Word; // Datensatzlaenge

    Reserved1 : Word; // Reserviert

    FlagNotFinishTrans: Byte; // Flag fuer nichtbeendete Transaktionen

    FlagScrambling : Byte; // Flag fuer die Verschluesselung

    Reserved2 : Array[0..11] of Byte;

    ExistsMDX : Byte; // Bei 01H existiert eine MDX-Datei

    Reserved3 : Array[0..2] of Byte;

    End;



    type tDBFField = Record

    FieldName : tChr10; // Name der Spalte

    FieldType : Char; // Typ des Feldes

    FieldAddress: LongWord; // Datenadresse des Feldes im Speicher

    FieldLen : Byte; // Laenge des Feldes

    FieldDec : Byte; // Zahl der Nachkommastellen

    Reserved : Array[1..14] of Byte;

    End;



    type tDBTHeader = Record

    NextFreeRecord : LongWord; // Zeiger auf den ersten freien Block

    Reserved1 : LongWord; // wird nicht benuetzt

    FileNameDBF : tChr8; // Name der DBF-Datei

    DBIIIHeader : Byte; // Sagt aus ob es sich um eine DBIII oder DBIV handelt

    Reserved2 : Array[0..2] of Byte;

    BlockSize

    : Array[0..1] of Byte; // Laenge des Blocks

    End;

    type tDBTIVBlockHeader = Record

    BlockStart : LongWord;

    TextLen : LongWord;

    End;



    // ---------------------------------------------------------------------------------



    Function tcDBase.getData(iFieldPos : LongWord) : Variant;

    // Lesen des angebenen Feldes.



    var Field : tcDBaseHeaderField;

    Data : String;

    Len : LongWord;

    p : LongWord;

    l : LongInt;

    dt : tDateTime;



    Begin

    Field:=fHeaderFields[iFieldPos];

    len:=Fields[iFieldPos].Length;

    p:=fHeaderFieldsPos[iFieldPos];

    Data[0]:=chr(len);

    move(fRecordBuffer[p], Data[1], Len);

    Case Field.Typ of

    tDBaseFT_Char : Result:=TrimRight(Data);

    tDBaseFT_Numeric: if Fields[iFieldPos].Decimal=0 then

    Begin

    l:=StrToInt(Trim(Data));

    Result:=l;

    End

    else

    Begin

    Writeln(Data);

    // StrToFloat

    End;

    tDBaseFT_Logical: Result:=(Data[1] in ['T','t','J','j']);

    tDBaseFT_Date : Begin

    Data:=trim(Data);

    if Data='' then

    dt:=0

    else

    dt:=EncodeDate(

    StrToInt(Copy(Data,1,4)),

    StrToInt(Copy(Data,5,2)),

    StrToInt(Copy(Data,7,2)));

    Result:=dt;

    End;

    tDBaseFT_Memo : Begin

    Data:=trim(Data);

    if Data<>'' then

    Begin

    l:=StrToInt(Data);

    if l>0 then

    Result:=fDBaseDBT.ReadMemoryText(l);

    End;

    End;

    End;

    End;



    Procedure tcDBase.setData(iFieldPos : LongWord; iData : Variant);

    // Das angegebene Feld mit den Daten befuellen.



    var Field : tcDBaseHeaderField;

    Data : String;

    Len : LongWord;

    p : LongWord;

    DataTyp: Word;



    Function Date2dBase : String;



    var y,m,d : Word;

    sy : tStr4;

    sm,sd : tStr2;



    Begin

    DecodeDate(iData,y,m,d);

    sy:=IntToStr(y);

    sm:=IntToStr(m);

    sd:=IntToStr(d);

    sy:=iif(y<10,' '+sy,sy);

    sm:=iif(m<10,' '+sm,sm);

    sd:=iif(d<10,' '+sd,sd);

    Result:=sy+sm+sd;

    End;



    label exit_error;



    Begin

    Field:=fHeaderFields[iFieldPos];

    len:=Fields[iFieldPos].Length;

    p:=fHeaderFieldsPos[iFieldPos];

    DataTyp:=VarType(iData);

    Case Field.Typ of

    tDBaseFT_Char : Begin

    if DataTyp<>VarString then goto exit_error;

    Data:=iData;

    Data:=Data+FillString(Len-Length(Data), #32);

    End;

    tDBaseFT_Numeric: Begin

    if not DataTyp in [VarByte, VarWord, VarLongWord]

    then goto exit_error;

    Data:=inttostr(iData);

    Data:=FillString(Len-Length(Data), #32)+Data;

    End;

    tDBaseFT_Logical: Begin

    if DataTyp<>VarBoolean then goto exit_error;

    Data:=iif(iData,'T','F');

    End;

    tDBaseFT_Date : Begin

    if DataTyp<>VarExtended then goto exit_error;

    Data:=Date2dBase;

    End;

    tDBaseFT_Memo : Begin

    End;

    End;

    move(Data[1], fRecordBuffer[p], Len);

    exit;



    exit_error:

    Writeln('falsches Format');

    Readln;

    End;



    Function tcDBase.CalcFilePosition : LongInt;



    Begin

    Result:=fFilePosData+(fRow * (fRecordSize+1))

    End;





    Procedure tcDBase.SetRow(iRow : LongWord);

    // An den angegeben Record springen



    var chdel : Char;



    Begin

    if iRow>=fRecordCount then exit;

    fRow:=iRow;

    fFileStream.Position:=CalcFilePosition;

    fFileStream.ReadBuffer(chdel,1);

    fRecordDeleted:=chdel='*';

    fFileStream.ReadBuffer(fRecordBuffer^,fRecordSize);

    End;



    Procedure tcDBase.SetRecordDeleted(iDeleted : Boolean);

    // Setzen des Record-Delete-Zeichens



    var chdel : Char;



    Begin

    fRecordDeleted:=iDeleted;

    if fRecordDeleted

    then chDel:='*'

    else chDel:=' ';

    fFileStream.Position:=CalcFilePosition;

    fFileStream.WriteBuffer(chdel,1);

    End;



    Procedure tcDBase.AddField(iName : tStr10; iTyp : tDBaseFieldTyp;

    iLength, iDecimal : Byte);

    // Ein neues Feld hinzufuegen. 4



    var p : LongWord;



    Begin

    if fHeaderFieldMod=false then exit;

    // Writeln(fFieldCount,':',iName,',',ord(iTyp),',',iLength,',',iDecimal);

    fHeaderFields[fFieldCount].Create(iName, iTyp, iLength, iDecimal);

    if fFieldCount=0

    then p:=0

    else p:=fHeaderFieldsPos[fFieldCount-1] + fHeaderFields[fFieldCount-1].Length;

    fHeaderFieldsPos[fFieldCount]:=p;

    inc(fFieldCount);

    End;



    Procedure tcDBase.Update;

    // Aktuellen Satz Updaten.



    Begin

    // Positionieren im Stream. +1 da das 1. Byte das Delete-Flag ist.

    fFileStream.Position:=CalcFilePosition+1;

    // Writeln('Upd pos:',fFileStream.Position,',',fRecordSize);

    fFileStream.WriteBuffer(fRecordBuffer^,fRecordSize);

    End;



    Procedure tcDBase.AppendBlank;

    // Einen leeren Satz hinzufuegen.



    Var chdel : Char;



    Begin

    // Wenn der 1. Satz geschrieben wird, dann die Feld-Definitionen auch schreiben

    if fHeaderFieldMod then

    Begin

    WriteHeader;

    WriteFields;

    fHeaderFieldMod:=false;

    End;



    // Anzahl der Saetze und die aktuelle Position berechnen

    inc(fRecordCount);

    fRow:=fRecordCount-1;



    fFileStream.Position:=CalcFilePosition;

    // Loesch-Kennzeichen speichern

    chdel:=' ';

    fFileStream.WriteBuffer(chdel,1);

    // Record speichern

    // Writeln('Apd pos:',fFileStream.Position);



    FillChar(fRecordBuffer^, fRecordSize, #32);

    fFileStream.WriteBuffer(fRecordBuffer^,fRecordSize);

    // Header aktualisieren

    WriteHeader;

    SetRow(fRow);

    End;



    Procedure tcDBase.WriteHeader;

    // Schreiben des Headers



    var Header : tDBFHeader;

    Y, M, D: Word;



    Begin

    fFileStream.Position:=0;



    FillChar(Header, Sizeof(tDBFHeader), #0);

    Header.Version :=DBaseVersionDBIII;

    DecodeDate(now,Y,M,D);

    if Y<2000

    then Y:=Y-1900

    else Y:=Y-2000;

    Header.WriteDate.Year :=Y;

    Header.WriteDate.Month:=M;

    Header.WriteDate.Day :=D;

    Header.RecCount := fRecordCount;

    Header.HeaderSize := fHeaderSize;

    Header.RecordSize := fRecordSize+1;

    fFileStream.WriteBuffer(Header, Sizeof(tDBFHeader));

    fFilePosFieldDef:=fFileStream.Position;

    End;



    Procedure tcDBase.ReadHeader;

    // Lesen der Header-Informationen



    var Header : tDBFHeader;

    FileNameDBT: tFileName;



    Begin

    fFileStream.Position:=0;

    FileNameDBT:='';

    fFileStream.ReadBuffer(Header, Sizeof(tDBFHeader));

    fRecordSize:=Header.RecordSize-1;

    case Header.Version of

    DBaseVersionDBIII: Begin

    fVersion:=tDBaseVer_III;

    End;

    DBaseVersionDBIIIM: Begin

    fVersion:=tDBaseVer_III;

    FileNameDBT:=ChangeFileExt(fFileName,EXT_UC_DBT);

    End;

    // DBaseVersionDBIV: fVersion:=tDBaseVer_IV;

    DBaseVersionDBIVM : Begin

    fVersion:=tDBaseVer_IV;

    FileNameDBT:=ChangeFileExt(fFileName,EXT_UC_DBT);

    End;

    else Begin

    Writeln('Falsche DBase-Version');

    Exit;

    End;

    end;

    fHeaderSize :=Header.HeaderSize;

    fRecordCount :=Header.RecCount;

    fFilePosFieldDef:=fFileStream.Position;

    GetMem(fRecordBuffer, fRecordSize);



    // Memory-Datei verarbeiten

    if FileExists(FileNameDBT)

    then fDBaseDBT.Create(FileNameDBT, fVersion)

    else fDBaseDBT:=nil;

    End;



    Procedure tcDBase.WriteFields;



    var FNr : LongWord;

    MemField: tcDBaseHeaderField;

    Field : tDBFField;

    NameC : cString[10];

    efd : byte; // Ende der Felddefinition



    Begin

    fFileStream.Position:=fFilePosFieldDef;

    fRecordSize:=0;

    for FNr:=0 to fFieldCount-1 do

    Begin

    fillchar(Field,sizeof(tDBFField),#0);

    MemField:=fHeaderFields[FNr];

    NameC:=MemField.Name;

    StrLCopy(Field.FieldName, @NameC, length(MemField.Name));

    Case MemField.Typ of

    tDBaseFT_Char : Field.FieldType:=DBaseFieldType_Char;

    tDBaseFT_Numeric: Field.FieldType:=DBaseFieldType_Numeric_1;

    tDBaseFT_Logical: Field.FieldType:=DBaseFieldType_Logical;

    tDBaseFT_Date : Field.FieldType:=DBaseFieldType_Date;

    tDBaseFT_Memo : Field.FieldType:=DBaseFieldType_Memo;

    end;

    Field.FieldLen:=MemField.Length;

    Field.FieldDec:=MemField.Decimal;

    fFileStream.WriteBuffer(Field, SizeOf(tDBFField));

    fRecordSize:=fRecordSize+Field.FieldLen;

    End;

    // Ende Zeichen schreiben

    efd:= PNFSTREPLACEMENT0 d;

    fFileStream.WriteBuffer(efd, 1);



    // Headerinformationen speichern

    fHeaderSize:=fFileStream.Position;

    fFilePosData:=fHeaderSize;



    // RecordBuffer definieren

    if fRecordBuffer=nil then

    GetMem(fRecordBuffer, fRecordSize-1);

    End;



    Procedure tcDBase.ReadFields;

    // Lesen der Feld-Informationen



    var Field : tDBFField;

    NameC : tChr20;

    Typ : tDBaseFieldTyp;

    si : LongWord;

    efd : byte; // Ende der Felddefinition



    Begin

    fFileStream.Position:=fFilePosFieldDef;

    si:=fHeaderSize-1;

    Repeat

    fFileStream.ReadBuffer(Field, SizeOf(tDBFField));

    FillChar(NameC, sizeof(NameC), #0);

    strLCopy(NameC, Field.FieldName, 11);

    Case Field.FieldType of

    DBaseFieldType_Char : Typ:=tDBaseFT_Char;

    DBaseFieldType_Numeric_1,

    DBaseFieldType_Numeric_2 : Typ:=tDBaseFT_Numeric;

    DBaseFieldType_Logical : Typ:=tDBaseFT_Logical;

    DBaseFieldType_Date : Typ:=tDBaseFT_Date;

    DBaseFieldType_Memo : Typ:=tDBaseFT_Memo;

    end;

    AddField(strPas(NameC), Typ, Field.FieldLen, Field.FieldDec);

    Until fFileStream.Position=si;



    // Check auf Ende der FeldDefintion. Muss x0D

    fFileStream.ReadBuffer(efd, 1);

    if efd<> PNFSTREPLACEMENT0 d then

    Writeln('falsches Feld-EndDefinition');



    fFilePosData:=fFileStream.Position;

    End;



    Constructor tcDBase.Create(Const iFileName : tFileName);

    // DBF-Datei oeffnen



    Begin

    inherited Create;

    fFileName:=iFileName;

    if ExtractFileExt(fFileName)='' then

    fFileName:=fFileName+EXT_LC_DBF;

    fHeaderFieldMod:=true;

    fillChar(fHeaderFields, sizeof(tArrDBaseHeaderFields), #0);

    if (FileExists(fFileName)) and (FileGetSize(fFileName)>0)

    then // Datei existiert und wird geoeffnet

    Begin

    fFileStream.Create(fFileName,fmOpen);

    ReadHeader;

    if fRecordCount>0 then

    Begin

    ReadFields;

    fHeaderFieldMod:=false;

    End;

    End

    else // Datei neu erstellen

    Begin

    fFileStream.Create(fFileName,fmCreate); // Leere Datei anlegen

    fRecordCount:=0;

    fRecordSize :=0;

    WriteHeader;

    End;

    End;



    Destructor tcDBase.Destroy;

    // DBF-Datei schliessen



    var cou : LongInt;



    Begin

    if fRecordBuffer<>nil then

    FreeMem(fRecordBuffer, fRecordSize);

    for cou:=0 to fFieldCount-1 do

    Begin

    fHeaderFields[cou].Destroy;

    End;



    fFileStream.Destroy;

    if fDBaseDBT<>nil then

    fDBaseDBT.Destroy;

    inherited Destroy;

    End;



    // ---------------------------------------------------------------------------------



    Constructor tcDBaseHeaderField.Create(Const iName : tStr11; Const iTyp : tDBaseFieldTyp;

    Const iLength : LongWord; Const iDecimal : LongWord);

    // Speichern der Feld-Informationen im Speicher



    Begin

    inherited Create;

    fName :=UpperCase(iName);

    fTyp :=iTyp;

    fDecimal:=0;

    case fTyp of

    tDBaseFT_Char : fLength :=iLength;

    tDBaseFT_Numeric: Begin

    fLength :=iLength;

    fDecimal:=iDecimal;

    End;

    tDBaseFT_Logical: fLength:=1;

    tDBaseFT_Date : fLength:=8;

    tDBaseFT_Memo : fLength:=10;

    end;



    End;



    // ---------------------------------------------------------------------------------



    Procedure tcDBaseDBT.ReadMemoryHeader;

    // Lesen der Memory-Header informationen



    Var Header : tDBTHeader;



    Begin

    fFileStream.Position:=0;

    fFileStream.ReadBuffer(Header, sizeof(tDBTHeader));

    if fVersion=tDBaseVer_III

    then fBlockSize:=512

    else fBlockSize:=Header.BlockSize[0]*256+Header.BlockSize[1];

    GetMem(fBlockBuffer,fBlockSize);

    fNextFreeRec:=Header.NextFreeRecord;

    End;



    Function tcDBaseDBT.ReadMemoryText(iBlockID : LongWord) : AnsiString;

    // Lesen des Memorys-Textes zum angegebenen Blocks



    Procedure ReadDBIII;



    var rb : LongInt;

    cou: LongInt;

    ex : Boolean;



    Begin

    ex:=false;

    repeat

    FillChar(fBlockBuffer^,fBlockSize,#0);

    rb:=fFileStream.Read(fBlockBuffer^, fBlockSize);

    for cou:=0 to rb-1 do

    Begin

    if fBlockBuffer^[cou]=A then

    Begin

    ex:=true;

    continue;

    End;

    Result:=Result+chr(fBlockBuffer^[cou]);

    End;

    until ex;

    End;



    Procedure ReadDBIV;



    var BlockHeader: tDBTIVBlockHeader;

    p : pChar;



    Begin

    fFileStream.ReadBuffer(BlockHeader, sizeof(tDBTIVBlockHeader));

    if BlockHeader.BlockStart<> PNFSTREPLACEMENT0 08FFFF then // In der Datei: FF FF 08 00

    exit;

    GetMem(p,BlockHeader.TextLen);

    fFileStream.ReadBuffer(p^,BlockHeader.TextLen);

    AnsiSetString(Result, p, BlockHeader.TextLen);

    FreeMem(p,BlockHeader.TextLen);

    End;



    Begin

    Result:='';

    fFileStream.Position:=iBlockID * fBlockSize;

    // Writeln(tohex(fFileStream.Position));

    case fVersion of

    tDBaseVer_III: ReadDBIII;

    tDBaseVer_IV : ReadDBIV;

    End;

    End;



    Constructor tcDBaseDBT.Create(Const iFileName : tFileName; iVersion : tDBaseVersion);

    // Memory-Datei oeffnen.



    Begin

    inherited Create;

    fFileName:=iFileName;

    fVersion :=iVersion;

    fFileStream.Create(fFileName,fmOpen);

    ReadMemoryHeader;

    End;



    Destructor tcDBaseDBT.Destroy;

    // Memory-Datei schliessen.



    Begin

    if fBlockBuffer<>nil then

    FreeMem(fBlockBuffer,fBlockSize);

    fFileStream.Destroy;

    inherited Destroy;

    End;



    Initialization

    End.


    bye,
    Wolfgang
  • 0 users

This list is based on users active over the last 30 minutes.