- Moderated by:
- Admins-Forum
Unit: dBase
-
- registered:
- December 2006
- Status:
- offline
- last visit:
- 28.06.10
- Posts:
- 82
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