Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.
how to read .dbf file from delphi 7 ?
hello every body,
i want simply to connect and retrive data from .dbf fie. i could by your help make a connection to that folder but when ever i couldent retrive data can you help me ?
here is my code for connection
var
strDBFolder: String;
tmpStringList, tmpStringList2: TStringList;
intX: Integer;
begin
tmpStringList := TStringList.Create;
tmpStringList2 := TStringList.Create;
strDBFolder := 'C:\Program Files\FingerTec\TCMSv2';
ADOConnection1.Close;
ADOConnection1.ConnectionS
strDBFolder +
';Extended Properties=dBASE IV;User ID=Admin;Password=;';
ADOConnection1.Open;
ADOConnection1.Connected := true ;
ADOConnection1.GetTableNam
showmessage(tmpStringList.
i want simply to connect and retrive data from .dbf fie. i could by your help make a connection to that folder but when ever i couldent retrive data can you help me ?
here is my code for connection
var
strDBFolder: String;
tmpStringList, tmpStringList2: TStringList;
intX: Integer;
begin
tmpStringList := TStringList.Create;
tmpStringList2 := TStringList.Create;
strDBFolder := 'C:\Program Files\FingerTec\TCMSv2';
ADOConnection1.Close;
ADOConnection1.ConnectionS
strDBFolder +
';Extended Properties=dBASE IV;User ID=Admin;Password=;';
ADOConnection1.Open;
ADOConnection1.Connected := true ;
ADOConnection1.GetTableNam
showmessage(tmpStringList.
Who is Participating?
Experts Exchange Solution brought to you by
Enjoy your complimentary solution view.
Get every solution instantly with Premium.
Start your 7-day free trial.
I wear a lot of hats...
"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
i have added this code :
for intX:=0 to 3 do
begin
ADOTable1.TableName := tmpStringList[ intX ];
ADOTable1.Active := true;
ADOTable1.Open ;
showmessage( 'Fields for table : ' + UpperCase( ADOTable1.TableName ) + #13#10 + ADOTable1.GetFieldnames(tm
but an error message keep appearing : external table is not in the expected format
end;
for intX:=0 to 3 do
begin
ADOTable1.TableName := tmpStringList[ intX ];
ADOTable1.Active := true;
ADOTable1.Open ;
showmessage( 'Fields for table : ' + UpperCase( ADOTable1.TableName ) + #13#10 + ADOTable1.GetFieldnames(tm
but an error message keep appearing : external table is not in the expected format
end;
Hi here is a simple way to use DB component and table to read a dbf file on you local HDD without creating a database.
//loadDbTable --------------------------
Procedure loadDbTable(DBPath, DBTableName : String);
var i, j : Integer;
Begin
try
if SysUtils.DirectoryExists(D
if FileExists(DBTableName) then begin
Database.Connected := False;
Table.Active := False;
Database.Params.Clear;
Database.Params.Add('TYPE=
Database.Params.Add('DEFAU
Database.Params.Add('ENABL
Database.Params.Add('PATH=
Database.Connected := True;
Table.DatabaseName := ShpDatabase.DatabaseName;
Table.TableName := ExtractFileName(DBTableNam
Table.Active := True;
//Add all the fields to the title combo or grid or something...
For i := 0 to Table.FieldCount - 1 do begin
dbfCheckListBox.Items.Add(
end;
// Read the data like normally
While not EOF(Table) do....
end;
end;
except
end;
end;
Sorry you need to add these if you can go this route...
var
Database : TDataBase; //Std delphi component
Table : TTable; //Std delphi component
var
Database : TDataBase; //Std delphi component
Table : TTable; //Std delphi component
this is my code
var
strDBFolder: String;
tmpStringList, tmpStringList2: TStringList;
intX : integer ;
begin
strDBFolder := 'C:\Program Files\FingerTec\TCMSv2';
tmpStringList := TStringList.Create;
ADOConnection1.ConnectionS
strDBFolder +
';Extended Properties=dBASE II;User ID=Admin;Password=;';
ADOConnection1.Open;
ADOConnection1.GetTableNam
showmessage( tmpStringList.Text );
//FreeAndNil( tmpStringList );
showmessage('the connection is ok') ;
//DOConnection1.
for intX:=1 to 3 do
begin
ADOTable1.TableName := tmpStringList[ intX ];
ADOTable1.GetFieldNames( tmpStringList2 );
showmessage( 'Fields for table : ' + UpperCase( tmpStringList[ intX ] ) + tmpStringList2.Text );
end;
FreeAndNil( tmpStringList );
FreeAndNil( tmpStringList2 );
ADOConnection1.Close;
here i could see the message that contained all tables names but when ever my loop started an error message saying missing connection or connection string , if i tried to but a connection string to my ADOTable another error message said external tables is not the expected format
what do you think the reason ?
how do i know my .dbf file type ?
var
strDBFolder: String;
tmpStringList, tmpStringList2: TStringList;
intX : integer ;
begin
strDBFolder := 'C:\Program Files\FingerTec\TCMSv2';
tmpStringList := TStringList.Create;
ADOConnection1.ConnectionS
strDBFolder +
';Extended Properties=dBASE II;User ID=Admin;Password=;';
ADOConnection1.Open;
ADOConnection1.GetTableNam
showmessage( tmpStringList.Text );
//FreeAndNil( tmpStringList );
showmessage('the connection is ok') ;
//DOConnection1.
for intX:=1 to 3 do
begin
ADOTable1.TableName := tmpStringList[ intX ];
ADOTable1.GetFieldNames( tmpStringList2 );
showmessage( 'Fields for table : ' + UpperCase( tmpStringList[ intX ] ) + tmpStringList2.Text );
end;
FreeAndNil( tmpStringList );
FreeAndNil( tmpStringList2 );
ADOConnection1.Close;
here i could see the message that contained all tables names but when ever my loop started an error message saying missing connection or connection string , if i tried to but a connection string to my ADOTable another error message said external tables is not the expected format
what do you think the reason ?
how do i know my .dbf file type ?
Sorry I'm not familliar ADO. We only use BDE for simple stuf and some other very expensive component suite(Unidac), and As far as reading a ‘dBASE IV’ Table on your local HDD? this should work. You might need to change the language driver. I have "PARADOX" in the example but you may need to change to"DBASE".
Experts Exchange Solution brought to you by
Your issues matter to us.
Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.
Start your 7-day free trial
your example dose not work with me because i could not define table as TTable or database as Tdatabase , although i added BDE to my uses
aldahan, first of all to have the peter's sample working just add ttable and tdatabase to your form (from BDE palette in D7)
Anyway can you open these dbf from ms access? If so you should be able to do it using ado too, but you have to set the proper connection string depending on wich Dbase kind are them (dBase III, IV or 5)
Note that them could also be some FoxPro dbf tables. In this case you should use the MS ODBC driver to access them. Take a look here http://www.connectionstrings.com/dbf-foxpro
Anyway can you open these dbf from ms access? If so you should be able to do it using ado too, but you have to set the proper connection string depending on wich Dbase kind are them (dBase III, IV or 5)
Note that them could also be some FoxPro dbf tables. In this case you should use the MS ODBC driver to access them. Take a look here http://www.connectionstrings.com/dbf-foxpro
Hi all a few mods this should be a bit clearer. hope this helps
//BitBtn1Click --------------------------
procedure TForm1.BitBtn1Click(Sender
begin
With OpenDialog1 do Begin
filter := 'DB Files|*.dbf';
if Execute Then begin
loadDbTable(ExtractFilePat
end;
end;
end;
// NOTE : Add "DB, DBTables" to your uses;
//LoadDbTable --------------------------
Procedure TForm1.LoadDbTable(DBPath,
var i, j : Integer;
Database : TDatabase;
Table : TTable;
Begin
Try
Database := TDatabase.Create(Self);
Table := TTable.Create(Self);
try
if SysUtils.DirectoryExists(D
if FileExists(DBTableName) then begin
Database.Connected := False;
Table.Active := False;
Database.Params.Clear;
Database.Params.Add('TYPE=
Database.Params.Add('DEFAU
Database.Params.Add('ENABL
Database.Params.Add('PATH=
Table.DatabaseName := Database.Name;
Table.TableName := ExtractFileName(DBTableNam
Table.Active := True;
//Add all the fields to the title combo or grid or something...
//Make sure you add some cols to the grid, before adding the fields
For i := 0 to Table.FieldCount - 1 do begin
StringGrid1.Cells[i, 0] := Table.FieldDefs.Items[i].N
end;
// Read the data
end;
end;
except
end;
finally
Database.Free;
Table.Free;
end;
end;
//BitBtn1Click --------------------------
procedure TForm1.BitBtn1Click(Sender
begin
With OpenDialog1 do Begin
filter := 'DB Files|*.dbf';
if Execute Then begin
loadDbTable(ExtractFilePat
end;
end;
end;
// NOTE : Add "DB, DBTables" to your uses;
//LoadDbTable --------------------------
Procedure TForm1.LoadDbTable(DBPath,
var i, j : Integer;
Database : TDatabase;
Table : TTable;
Begin
Try
Database := TDatabase.Create(Self);
Table := TTable.Create(Self);
try
if SysUtils.DirectoryExists(D
if FileExists(DBTableName) then begin
Database.Connected := False;
Table.Active := False;
Database.Params.Clear;
Database.Params.Add('TYPE=
Database.Params.Add('DEFAU
Database.Params.Add('ENABL
Database.Params.Add('PATH=
Table.DatabaseName := Database.Name;
Table.TableName := ExtractFileName(DBTableNam
Table.Active := True;
//Add all the fields to the title combo or grid or something...
//Make sure you add some cols to the grid, before adding the fields
For i := 0 to Table.FieldCount - 1 do begin
StringGrid1.Cells[i, 0] := Table.FieldDefs.Items[i].N
end;
// Read the data
end;
end;
except
end;
finally
Database.Free;
Table.Free;
end;
end;
Ok, here is a working example, works in D6 and D2010. Just add a TStringGrid and a TBitBtn to a from.
//------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, Grids, DB, DBTables;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
BitBtn1: TBitBtn;
OpenDialog1: TOpenDialog;
procedure BitBtn1Click(Sender: TObject);
private
Procedure LoadDbTable(DBPath, DBTableName : String);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//BitBtn1Click --------------------------
procedure TForm1.BitBtn1Click(Sender
begin
With OpenDialog1 do Begin
filter := 'DB Files|*.dbf';
if Execute Then begin
loadDbTable(ExtractFilePat
end;
end;
end;
// ADD "DB, DBTables" to your uses;
//LoadDbTable --------------------------
Procedure TForm1.LoadDbTable(DBPath,
var i, j : Integer;
Database : TDatabase;
Table : TTable;
Begin
Try
Screen.Cursor := crHourGlass;
Database := TDatabase.Create(Self);
Table := TTable.Create(Self);
try
if SysUtils.DirectoryExists(D
if FileExists(DBTableName) then begin
Database.Connected := False;
Table.Active := False;
Database.Params.Clear;
Database.Params.Add('TYPE=
Database.Params.Add('DEFAU
Database.Params.Add('ENABL
Database.Params.Add('PATH=
Table.DatabaseName := Database.Name;
Table.TableName := ExtractFileName(DBTableNam
Table.Active := True;
For i := 0 to Table.FieldCount - 1 do begin
If StringGrid1.ColCount < i then StringGrid1.ColCount := StringGrid1.ColCount + 1;
StringGrid1.Cells[i, 0] := Table.FieldDefs.Items[i].N
j := 1;
while not (Table.Eof) do begin
If StringGrid1.RowCount < j then StringGrid1.RowCount := StringGrid1.RowCount + 1;
StringGrid1.Cells[i, j] := Table.Fields[i].AsString;
inc(j);
Table.Next; //Goto next record
end;
Table.First; //goto first record
end;
end;
end;
except
MessageDlg('Unable to load '+DBTableName, mtError, [mbOk], 0);
end;
finally
Database.Free;
Table.Free;
Screen.Cursor := crDefault;
end;
end;
end.
//------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, Grids, DB, DBTables;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
BitBtn1: TBitBtn;
OpenDialog1: TOpenDialog;
procedure BitBtn1Click(Sender: TObject);
private
Procedure LoadDbTable(DBPath, DBTableName : String);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//BitBtn1Click --------------------------
procedure TForm1.BitBtn1Click(Sender
begin
With OpenDialog1 do Begin
filter := 'DB Files|*.dbf';
if Execute Then begin
loadDbTable(ExtractFilePat
end;
end;
end;
// ADD "DB, DBTables" to your uses;
//LoadDbTable --------------------------
Procedure TForm1.LoadDbTable(DBPath,
var i, j : Integer;
Database : TDatabase;
Table : TTable;
Begin
Try
Screen.Cursor := crHourGlass;
Database := TDatabase.Create(Self);
Table := TTable.Create(Self);
try
if SysUtils.DirectoryExists(D
if FileExists(DBTableName) then begin
Database.Connected := False;
Table.Active := False;
Database.Params.Clear;
Database.Params.Add('TYPE=
Database.Params.Add('DEFAU
Database.Params.Add('ENABL
Database.Params.Add('PATH=
Table.DatabaseName := Database.Name;
Table.TableName := ExtractFileName(DBTableNam
Table.Active := True;
For i := 0 to Table.FieldCount - 1 do begin
If StringGrid1.ColCount < i then StringGrid1.ColCount := StringGrid1.ColCount + 1;
StringGrid1.Cells[i, 0] := Table.FieldDefs.Items[i].N
j := 1;
while not (Table.Eof) do begin
If StringGrid1.RowCount < j then StringGrid1.RowCount := StringGrid1.RowCount + 1;
StringGrid1.Cells[i, j] := Table.Fields[i].AsString;
inc(j);
Table.Next; //Goto next record
end;
Table.First; //goto first record
end;
end;
end;
except
MessageDlg('Unable to load '+DBTableName, mtError, [mbOk], 0);
end;
finally
Database.Free;
Table.Free;
Screen.Cursor := crDefault;
end;
end;
end.
You don't use jet 4 to connect to dbase table.Jet 4 is for Access 2000-2003.
Use BDE from the components palette.
Use BDE from the components palette.
thank you peter, i am so thankfull to your example here, i tried to use it but an error message said that an error occured while attempting to intialize the Borland Database Engine ( Error $2108)
hi there every body,
thank you for being helpful. i install bde again on my computer but know i got this error : could not find language driver
thank you for being helpful. i install bde again on my computer but know i got this error : could not find language driver
aldahan, first note that BDE is obsolete and no longer updated, then consider that if you use it you should distribute BDE with your application.
Also, wich delphi 7 are you using? Usually BDE is already installed with Delphi7, so why did you need to reinstall it?
Last, you didn't answer about the dbf type. Can you open it with MS Access? If so, you should open it using ADO too otherwise it could be, as said above, a FoxPro dbf file, so the approach should be different...
Also, wich delphi 7 are you using? Usually BDE is already installed with Delphi7, so why did you need to reinstall it?
Last, you didn't answer about the dbf type. Can you open it with MS Access? If so, you should open it using ADO too otherwise it could be, as said above, a FoxPro dbf file, so the approach should be different...
an answer to the "Cannot intialize the Borland Database Engine ( Error $2108)" problem exists on this site or check out http://support.embarcadero.com/article/35865
Alternatively here is the source for a component tat can read a dbf file without any DB engine support.
It reads an parses the file without the need for any additional recourses.
This code is quite old so it might need some fiddling if your are not using D6, D7
I’ve attached an demo exe so first check if you can view your file if ok give the component a try
//------------------------
unit MDBFTable;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DsgnIntf;
const
dBase_MaxRecCount = 1000000000;
dBase_MaxRecSize = 4000;
dBase_MaxFieldCount = 128;
dBase_MaxFieldWidth = 255;
dBase_MaxNumPrec = 16;
dBase_MaxMemoBytes = 16384;
dBase_MaxMemoRec = 512;
flgDeleted = #$2A;
flgUndeleted = #$20;
flgEOF = #$1A;
flgBOF = #$0D;
err_ErrorCode = 'Error code: ';
err_Warning='Warning';
err_Stop='Error';
err_BookMark='Cannot find bookmark';
err_NoRecords='No records';
err_InValidValue='Invalid value';
err_ChangeFileName='Cannot
err_IncorrectDBF='Incorrec
err_AccessOutRange='Access
err_WrongFieldDef='Wrong field definition';
err_FileNotOpen='File not open';
dBaseIIIPlus = $03;
dBaseIIIPlusMemo = $83;
type
PBoolean = ^Boolean;
TFilenameProperty = class(TStringProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
TDBFError = procedure(Sender: TObject;ErrorMsg:String) of object;
TFieldName = string[10];
TDBFBuffer = array[1..dBase_MaxRecSize]
TdBaseIIIPlus_Header = record
Version, //$03 without memo, $83 with memo
Year,
Month,
Day :Byte;
Recordcount :Longint;
HeaderSize,
RecordSize :Word;
Reserved1 :array[1..3] of Byte;
LANRsvd :array[1..13] of Byte;
Reserved2 :array[1..4] of Byte;
end;
TdBaseIVPlus_Header = record
Version, { 01234567
vvvmsssa
| || |
| || - presence of any memo file
| |- presence of an SQL table
| - presence of a dBASE IV memo
- indicate version number}
Year,
Month,
Day :Byte;
Recordcount :Longint;
HeaderSize,
RecordSize :Word;
Reserved1 :array[1..2] of Byte; //filled with 0
IncompleteTranstactionFlag
EncryptionFlag :byte; //$01 encrypted
MultiuserRsvd :array[1..12] of Byte;
MDXFlag, //$01 presence
LangDrvID :byte;
{ 001 - cp 437
002 - cp 850
100 - cp 852
102 - cp 865
101 - cp 866
104 - cp 895
200 - cp 1250
201 - cp 1251
003 - cp 1252 }
end;
TdBaseIIIPlus_Field = record
Name :array[1..10] of Char;
ClosingZero :byte;
FieldType :Char;
MemAddress :array[1..4] of Byte;
Width,
Decimals :Byte;
LAN1 :array[1..2] of Byte;
WorkAreaID :byte;
LAN2 :array[1..2] of Byte;
SetFields :byte;
Rsvd :byte;
end;
TdBaseIVPlus_Field = record
Name :array[1..10] of Char;
ClosingZero :byte;
FieldType :Char;
Rsvd1 :array[1..4] of Byte;
Width,
Decimals :Byte;
Rsvd2 :array[1..2] of Byte;
WorkAreaID :byte;
Rsvd3 :array[1..10] of Byte;
Indexed: byte;
end;
TDBTHeader = record
NextBlock :DWORD;
BlockSize :DWORD;
Reserved :array[1..504] of Char;
end;
PDBFField = ^TDBFField;
TDBFField = record
FieldName :TFieldname;
FieldType :TFieldType;
Size :word;
Decimals :Byte;
Offset :Word;
Indexed :boolean;
end;
TDBFStructure = record
FileName :string;
Year, Month, Day :Byte;
Version :byte;
RecordCount, DeletedCount :LongInt;
HeaderSize :Word;
RecordSize :Word;
MDXPresent :boolean;
Encrypted,
TransProt,
Memo, AnyMemo :boolean;
CodePage :word;
FieldCount :Word;
Data :TStringList;
Fields :TList;
end;
PRecInfo = ^TRecInfo;
TRecInfo = packed record
BookMark: integer;
UpdateStatus: TUpdateStatus;
BookmarkFlag: TBookmarkFlag;
end;
TDBFAccess = class(TPersistent)
private
FFile :TFileStream;
Fdb3Header :TdBaseIIIPlus_Header;
Fdb4Header :TdBaseIVPlus_Header;
Fdb3Field :TdBaseIIIPlus_Field;
Fdb4Field :TdBaseIVPlus_Field;
FDBF :TDBFStructure;
FResult :integer;
FOnDBFError:TDBFError;
FPackOnSave: Boolean;
FDB3 :boolean;
function CheckRange(FileSize :longint) :integer;
function CheckField(Field :TDBFField) :integer;
procedure OpenFile(const Filename :string);
procedure CreateFile(const Filename :string);
procedure CloseFile;
function ReadDBFHeader :integer;
function ReadDBFFieldDefs :integer;
function ReadDBFData :integer;
function WriteDB3Header(HB :TdBaseIIIPlus_Header) :integer;
function WriteDB4Header(HB :TdBaseIVPlus_Header) :integer;
function WriteDBFFieldDefs(AFields :TList) :integer;
function WriteDBFData(AFields :TList; AData :TStringList) :integer;
protected
procedure RaiseDBFError;
public
constructor Create;
destructor Destroy; override;
procedure LoadFromFile(const Filename :string);
procedure SaveToFile(const Filename :string);
property Structure :TDBFStructure read FDBF write FDBF;
property LastError :integer read FResult write FResult;
property OnDBFError:TDBFError read FOnDBFError write FOnDBFError;
property PackOnSave :Boolean read FPackOnSave write FPackOnSave;
property Dbase3 :boolean read FDB3 write FDB3;
end;
//PdBaseMemoRecord = ^TdBaseMemoRecord;
//TdBaseMemoRecord = array [0..dBase_MaxMemoBytes] of byte;
TMDBFTable = class(TDataset)
private
FAccess: TDBFAccess;
FStructure :TDBFStructure;
FData :tstringlist;
FRecSize, FRecBufSize: Integer;
FRecInfoOfs: Integer;
FCurRec: Integer;
FAbout, FFileName: string;
FLastBookmark: Integer;
FLastUpdate :string;
FOnDBFError:TDBFError;
FMakeBackup :Boolean;
FShowDeleted: Boolean;
FModified: Boolean;
FVersion: string;
FActiveFilter :boolean;
FMemoFile :TFileStream;
DBTHeader: TDBTHeader;
FMemoFilename :string;
function GetField(Index :integer) :TDBFField;
procedure DBFError(Sender: TObject; ErrorMsg :string);
function GetDeleted: Boolean;
procedure SetShowDeleted(const Value: Boolean);
procedure SetFilterActive(const Value: Boolean);
function GetFilterActive: Boolean;
function GetCodePage: word;
function GetDeletedCount: integer;
function GetEncrypted: boolean;
function GetPackOnSave: Boolean;
function GetTransactionProtected: boolean;
function GetWithMemo: Boolean;
procedure SetPackOnSave(const Value: Boolean);
protected
procedure SetNone(value :string);
procedure SetFilename(value :string);
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
function GetRecordSize: Word; override;
function GetFieldPointer(Buffer :PChar; Fields :TField) :PChar;
function GetActiveRecordBuffer :PChar;
procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
// procedure InternalRefresh; override;
procedure InternalClose; override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalGotoBookmark(Bookm
procedure InternalHandleException; override;
procedure InternalInitFieldDefs; override;
procedure InternalInitRecord(Buffer:
procedure InternalLast; override;
procedure InternalOpen; override;
procedure InternalPost; override;
procedure InternalInsert; override;
procedure InternalSetToRecord(Buffer
function IsCursorOpen: Boolean; override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
function GetRecordCount: Integer; override;
function GetRecNo: Integer; override;
procedure SetRecNo(Value: Integer); override;
function GetData(Field :TField; var Value :pchar; Buffer :PChar) :boolean;
function FindRecord(Restart, GoForward: Boolean): Boolean; override;
procedure Zap;
function HasMemo :boolean;
function ProcessFilter(Buffer:PChar
public
constructor Create(AOwner :TComponent); override;
procedure CreateTable(const FileName :string; Fields :TList; Dbase3 :boolean);
procedure Save;
function FindKey(const KeyValues: array of const): Boolean;
procedure GetFields(var Fields :TList);
function Locate(const KeyFields: string; const KeyValues: Variant;
Options: TLocateOptions): Boolean; override;
function GetMemoData(Field :TField): string;
procedure SetMemoData(Field :TField; Text :string);
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
{function GetBLOBData(Field :TField): TMemoryStream;
procedure SetBLOBData(Field :TField; BLOB :TMemoryStream);}
procedure Undelete;
property OriginalFields[Index :integer] :TDBFField read GetField;
property LastUpdate :string read FLastUpdate;
property Deleted :Boolean read GetDeleted;
property WithMemo :Boolean read GetWithMemo;
property DeletedCount :integer read GetDeletedCount;
property Modified :Boolean read FModified write FModified;
property Version :string read FVersion;
property CodePage :word read GetCodePage;
property TransactionProtected :boolean read GetTransactionProtected;
property Encrypted :boolean read GetEncrypted;
published
property About :string read fabout write SetNone;
property FileName: string read FFileName write SetFileName;
property MakeBackup :Boolean read FMakeBackup write FMakeBackup;
property ShowDeleted :Boolean read FShowDeleted write SetShowDeleted;
property PackOnSave :Boolean read GetPackOnSave write SetPackOnSave;
property Filter;
property Filtered :Boolean read GetFilterActive write SetFilterActive;
property Active;
property BeforeOpen;
property AfterOpen;
property BeforeClose;
property AfterClose;
property BeforeInsert;
property AfterInsert;
property BeforeEdit;
property AfterEdit;
property BeforePost;
property AfterPost;
property BeforeCancel;
property AfterCancel;
property BeforeDelete;
property AfterDelete;
property BeforeScroll;
property AfterScroll;
property OnDBFError:TDBFError read FOnDBFError write FOnDBFError;
property OnDeleteError;
property OnEditError;
property OnNewRecord;
property OnPostError;
property OnCalcFields;
end;
const
AboutInfo = 'MiTeC DBF Table 1.5 - © 1997,2002, MichaL MutL';
DBFOK = 0;
DBFIncorectFile =-1;
DBFOutOfRange =-2;
DBFWrongFieldDef=-3;
DBFInvalidValue =-4;
DBFNotOpened =-5;
DBFErrorMessages :array[0..5] of string = ('OK',Err_IncorrectDBF,
Err_AccessOutRange,
Err_WrongFieldDef,
Err_InValidValue,
Err_FileNotOpen);
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data',
RegisterPropertyEditor(Typ
end;
{TDBFAccess}
constructor TDBFAccess.Create;
begin
inherited create;
with fdbf do begin
data:=tstringlist.create;
fields:=tlist.create;
filename:='';
end;
end;
destructor TDBFAccess.Destroy;
begin
with fdbf do begin
data.free;
fields.free;
end;
inherited destroy;
end;
procedure TDBFAccess.OpenFile;
begin
if (filename<>'') and not assigned(ffile) then
ffile:=tfilestream.create(
end;
procedure TDBFAccess.CreateFile;
begin
if (filename<>'') then begin
if assigned(ffile) then begin
ffile.free;
ffile:=nil;
end;
if fileexists(filename) then
deletefile(filename);
ffile:=tfilestream.create(
end;
end;
procedure TDBFAccess.CloseFile;
begin
if assigned(ffile) then begin
ffile.free;
ffile:=nil;
end;
end;
function TDBFAccess.CheckRange;
begin
result:=dbfok;
if FileSize<(fdbf.recordcount
result:=DBFIncorectFile
else
if fdbf.recordcount>dBase_Max
result:=DBFOutOfRange
else
if fdbf.RecordSize>dBase_MaxR
result:=DBFOutOfRange
else
if fdbf.FieldCount>dBase_MaxF
result:=DBFOutOfRange;
end;
function TDBFAccess.CheckField;
begin
result:=dbfok;
with field do begin
if Size>dBase_MaxFieldWidth then
result:=DBFOutOfRange
else
case fieldType of
ftstring :if Decimals<>0 then
result:=DBFOutOfRange;
ftinteger :if (Size>30) or (Decimals<>0) then
result:=DBFOutOfRange;
ftfloat :if (Size>30) or (Decimals>size-2) then
result:=DBFOutOfRange
else
if Size+2<Decimals then
result:=DBFOutOfRange;
ftdate: if (Size<>8) or (Decimals<>0) then
result:=DBFOutOfRange;
ftboolean :if (Size<>1) or (Decimals<>0) then
result:=DBFOutOfRange;
ftmemo :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
ftblob :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
ftdbaseole :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
else
result:=DBFWrongFieldDef;
end;
end;
end;
function TDBFAccess.ReadDBFHeader;
var
buffer :byte;
begin
if assigned(ffile) then begin
try
setlasterror(0);
ffile.Seek(0,sofrombeginni
ffile.Read(Buffer,1);
ffile.Seek(0,sofrombeginni
if not(buffer in [$03..$F5]) then
result:=DBFIncorectFile
else
if buffer in [dBaseIIIPlus,dBaseIIIPlus
fdb3:=true;
ffile.Read(Fdb3Header,32);
with fdbf do begin
Year:=Fdb3Header.Year;
Month:=Fdb3Header.Month;
Day:=Fdb3Header.Day;
version:=3;
Recordcount:=Fdb3Header.Re
HeaderSize:=Fdb3Header.Hea
RecordSize:=Fdb3Header.Rec
FieldCount:=Pred(Pred(Head
mdxpresent:=false;
memo:=Fdb3Header.Version=d
anymemo:=memo;
codepage:=0;
encrypted:=false;
transprot:=false;
result:=CheckRange(ffile.S
end;
end else begin
ffile.Read(Fdb4Header,32);
fdb3:=false;
with fdbf do begin
Year:=Fdb4Header.Year;
Month:=Fdb4Header.Month;
Day:=Fdb4Header.Day;
case Fdb4Header.Version and 7 of
3 :version:=4;
else version:=5;
end;
Recordcount:=Fdb4Header.Re
HeaderSize:=Fdb4Header.Hea
RecordSize:=Fdb4Header.Rec
FieldCount:=Pred(Pred(Head
mdxpresent:=Fdb4Header.MDX
memo:=(Fdb4Header.Version and 128)=128;
anymemo:=(Fdb4Header.Versi
transprot:=Fdb4Header.Inco
encrypted:=Fdb4Header.Encr
case Fdb4Header.LangDrvID of
001 :codepage:=437;
002 :codepage:=850;
100 :codepage:=852;
102 :codepage:=865;
101 :codepage:=866;
104 :codepage:=895;
200 :codepage:=1250;
201 :codepage:=1251;
003 :codepage:=1252;
else
codepage:=0;
end;
result:=CheckRange(ffile.S
end;
end;
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.ReadDBFFieldDef
var
i,o :word;
b :byte;
Field :PDBFField;
begin
o:=1;
result:=dbfok;
if assigned(ffile) then begin
setlasterror(0);
try
ffile.Seek(32,sofrombeginn
if fdb3 then begin
for i:=1 to fdbf.FieldCount do
with fdbf do begin
new(field);
ffile.Read(Fdb3Field,32);
b:=1;
while (b<=10) and (Fdb3Field.Name[b]<>#0) do
Inc(b);
system.Move(Fdb3Field.Name
Field^.fieldName[0]:=Chr(P
if b>0 then
Field^.fieldName[0]:=Char(
case Fdb3Field.fieldType of
'C':Field^.FieldType:=ftst
'N': if Fdb3Field.Decimals>0 then
Field^.FieldType:=ftfloat
else
Field^.FieldType:=ftintege
'F':Field^.FieldType:=ftfl
'D':Field^.FieldType:=ftda
'L':Field^.FieldType:=ftbo
'M':Field^.FieldType:=ftme
'B':Field^.FieldType:=ftbl
'O':Field^.FieldType:=ftdb
end;
Field^.Size:=Fdb3Field.Wid
Field^.Decimals:=Fdb3Field
Field^.Offset:=o;
Field^.indexed:=Fdb3Field.
Inc(o,Fdb3Field.Width);
result:=CheckField(Field^)
if result=dbfok then
fields.add(field)
else
exit;
end;
end else begin
for i:=1 to fdbf.FieldCount do
with fdbf do begin
new(field);
ffile.Read(Fdb4Field,32);
b:=1;
while (b<=10) and (Fdb4Field.Name[b]<>#0) do
Inc(b);
system.Move(Fdb4Field.Name
Field^.fieldName[0]:=Chr(P
if b>0 then
Field^.fieldName[0]:=Char(
case Fdb4Field.fieldType of
'C':Field^.FieldType:=ftst
'N': if Fdb4Field.Decimals>0 then
Field^.FieldType:=ftfloat
else
Field^.FieldType:=ftintege
'F':Field^.FieldType:=ftfl
'D':Field^.FieldType:=ftda
'L':Field^.FieldType:=ftbo
'M':Field^.FieldType:=ftme
'B':Field^.FieldType:=ftbl
'O':Field^.FieldType:=ftdb
end;
Field^.Size:=Fdb4Field.Wid
Field^.Decimals:=Fdb4Field
Field^.Offset:=o;
Field^.indexed:=Fdb4Field.
Inc(o,Fdb4Field.Width);
result:=CheckField(Field^)
if result=dbfok then
fields.add(field)
else
exit;
end;
end;
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.ReadDBFData;
var
r :integer;
fbuffer :^TDBFBuffer;
begin
if assigned(ffile) then begin
ffile.seek(fDBF.HeaderSize
r:=fDBF.RecordSize;
while (ffile.position+fDBF.Recor
new(fbuffer);
r:=ffile.Read(fbuffer^,fDB
fdbf.data.add(strpas(pchar
end;
result:=dbfok;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDB3Header;
var
y,m,d :word;
begin
if assigned(ffile) then begin
result:=dbfok;
decodedate(date,y,m,d);
if y>2000 then
y:=y-2000
else
y:=y-1900;
hb.Year:=Y;
hb.Month:=M;
hb.Day:=D;
setlasterror(0);
try
ffile.Seek(0,sofrombeginni
ffile.Write(hb,32);
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDB4Header(
var
y,m,d :word;
begin
if assigned(ffile) then begin
result:=dbfok;
decodedate(date,y,m,d);
if y>2000 then
y:=y-2000
else
y:=y-1900;
hb.Year:=Y;
hb.Month:=M;
hb.Day:=D;
setlasterror(0);
try
ffile.Seek(0,sofrombeginni
ffile.Write(hb,32);
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDBFFieldDe
var
i :word;
begin
result:=dbfok;
if assigned(ffile) then begin
setlasterror(0);
try
if fdb3 then
for i:=0 to aFields.Count-1 do begin
FillChar(Fdb3Field,SizeOf(
Move(tdbffield(aFields.ite
case tdbffield(aFields.items[i]
ftstring: Fdb3Field.FieldType:='C';
ftinteger: Fdb3Field.FieldType:='N';
ftdate: Fdb3Field.FieldType:='D';
ftboolean: Fdb3Field.FieldType:='L';
ftmemo: Fdb3Field.FieldType:='M';
end;
Fdb3Field.Width:=tdbffield
Fdb3Field.Decimals:=tdbffi
Fdb3Field.SetFields:=byte(
ffile.Write(Fdb3Field,32);
end
else
for i:=0 to aFields.Count-1 do begin
FillChar(Fdb4Field,SizeOf(
Move(tdbffield(aFields.ite
case tdbffield(aFields.items[i]
ftstring: Fdb4Field.FieldType:='C';
ftinteger: Fdb4Field.FieldType:='N';
ftfloat: Fdb4Field.FieldType:='F';
ftdate: Fdb4Field.FieldType:='D';
ftboolean: Fdb4Field.FieldType:='L';
ftmemo: Fdb4Field.FieldType:='M';
ftblob: Fdb4Field.FieldType:='B';
ftdbaseole: Fdb4Field.FieldType:='O';
end;
Fdb4Field.Width:=tdbffield
Fdb4Field.Decimals:=tdbffi
Fdb4Field.Indexed:=byte(td
ffile.Write(Fdb4Field,32);
end
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDBFData;
var
fbuffer :pchar;
recsize,i :integer;
S:char;
begin
if assigned(ffile) then begin
result:=dbfok;
setlasterror(0);
recsize:=1;
for i:=0 to afields.count-1 do
recsize:=recsize+tdbffield
fbuffer:=stralloc(recsize+
try
S:=flgBOF;
ffile.write(S,1);
if assigned(adata) then begin
for i:=0 to adata.count-1 do
if not packonsave or (packonsave and (PChar(adata[i])[0]<>flgDe
StrCopy(FBuffer,PChar(adat
ffile.write(fBuffer^,recsi
end;
S:=flgEOF;
end;
ffile.write(S,1);
finally
strdispose(fbuffer);
end;
end else
result:=dbfnotopened;
end;
procedure TDBFAccess.RaiseDBFError;
var
s :string;
begin
if (fresult<0) then
s:=DBFErrorMessages[abs(fr
else
s:=Err_ErrorCode+inttostr(
if Assigned(FOnDBFError) then
FOnDBFError(Self,s);
Abort;
end;
procedure TDBFAccess.LoadFromFile;
begin
fdbf.filename:=filename;
fdbf.fields.clear;
fdbf.data.clear;
openfile(fdbf.filename);
fresult:=readdbfheader;
if fresult=dbfok then begin
fresult:=readdbffielddefs;
if fresult=dbfok then
begin
fresult:=readdbFData;
end;
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
procedure TDBFAccess.SaveToFile;
begin
createfile(filename);
if fdbf.version=3 then begin
{if fdbf.Memo then
Fdb3Header.Version:=dbasei
else
Fdb3Header.Version:=dbasei
if PackOnSave then
Fdb3Header.Recordcount:=fD
else
Fdb3Header.Recordcount:=fD
Fdb3Header.HeaderSize:=fDB
Fdb3Header.RecordSize:=fDB
fresult:=writedb3header(Fd
end else begin
{Fdb4Header.Version:=0;
Fdb4Header.Version:=Fdb4He
if fdbf.AnyMemo then
Fdb4Header.Version:=Fdb4He
if fdbf.Memo then
Fdb4Header.Version:=Fdb4He
Fdb4Header.MDXFlag:=byte(f
Fdb4Header.EncryptionFlag:
Fdb4Header.IncompleteTrans
if PackOnSave then
Fdb4Header.Recordcount:=fD
else
Fdb4Header.Recordcount:=fD
Fdb4Header.HeaderSize:=fDB
Fdb4Header.RecordSize:=fDB
fresult:=writedb4header(Fd
end;
if fresult=dbfok then begin
fresult:=writedbffielddefs
if fresult=dbfok then
fresult:=writedbFData(fdbf
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
{TMDBFTable}
constructor TMDBFTable.Create;
begin
inherited create(aowner);
faccess:=tdbfaccess.create
faccess.OnDbfError:=DBFErr
fabout:=aboutinfo;
fversion:='Unknown';
end;
function TMDBFTable.GetField;
begin
result:=tdbffield(FStructu
end;
procedure TMDBFTable.DBFError(Sender
begin
if Assigned(FOnDBFError) then
FOnDBFError(Self,ErrorMsg)
MessageBox(0,PChar(ErrorMs
end;
procedure TMDBFTable.SetFilename;
begin
if active then begin
if Assigned(FOnDBFError) then
FOnDBFError(Self,Err_Chang
else
MessageBox(0,Err_ChangeFil
end else
ffilename:=value;
end;
procedure TMDBFTable.SetNone;
begin
end;
procedure TMDBFTable.InternalOpen;
var
I: Integer;
y :word;
begin
faccess.loadfromfile(ffile
FStructure:=FAccess.Struct
FData:=FStructure.data;
FStructure.DeletedCount:=0
for I:=1 to FData.Count do begin
FData.Objects[I-1]:=Pointe
if PChar(FData[i-1])[0]=flgDe
Inc(FStructure.Deletedcoun
end;
if WithMemo then begin
try
FMemoFilename:=changefilee
FMemoFile:=TFileStream.Cre
FMemoFile.Seek(0,soFromBeg
FMemoFile.ReadBuffer(DBTHe
except
on e:exception do
showmessage(e.message);
end;
end;
fversion:='dBase ?';
case FStructure.version of
3: fversion:='dBase III+';
4: fversion:='dBase IV';
5: fversion:='dBase/Win';
end;
if FStructure.Year>50 then
y:=FStructure.Year+1900
else
y:=FStructure.Year+2000;
FLastUpdate:=datetostr(enc
FLastBookmark:=FData.Count
FCurRec:=-1;
frecsize:=1;
for i:=0 to FStructure.fields.count-1 do
frecsize:=frecsize+tdbffie
FRecInfoOfs:=frecsize;
FRecBufSize:=FRecInfoOfs+S
BookmarkSize:=SizeOf(Integ
InternalInitFieldDefs;
if DefaultFields then
CreateFields;
BindFields(True);
end;
procedure TMDBFTable.InternalClose;
begin
if Assigned(FMemoFile) then begin
FMemoFile.Free;
FMemoFile:=nil;
end;
if DefaultFields then
DestroyFields;
FLastBookmark:=0;
FCurRec:=-1;
end;
function TMDBFTable.IsCursorOpen: Boolean;
begin
result:=Assigned(FData);
end;
procedure TMDBFTable.InternalInitFie
var
i,s :integer;
begin
FieldDefs.Clear;
with FStructure.fields do
for i:=0 to FStructure.fieldcount-1 do begin
if tdbffield(items[i]^).field
s:=tdbffield(items[i]^).si
else
s:=0;
TFieldDef.Create(FieldDefs
tdbffield(items[i]^).field
end;
end;
procedure TMDBFTable.InternalHandleE
begin
Application.HandleExceptio
end;
procedure TMDBFTable.InternalGotoBoo
var
Index: Integer;
begin
Index:=FData.IndexOfObject
if Index<>-1 then
FCurRec:=Index
else
DatabaseError(Err_BookMark
end;
procedure TMDBFTable.InternalSetToRe
begin
InternalGotoBookmark(@PRec
end;
function TMDBFTable.GetBookmarkFlag
begin
Result:=PRecInfo(Buffer+FR
end;
procedure TMDBFTable.SetBookmarkFlag
begin
PRecInfo(Buffer+FRecInfoOf
end;
procedure TMDBFTable.GetBookmarkData
begin
PInteger(Data)^:=PRecInfo(
end;
procedure TMDBFTable.SetBookmarkData
begin
PRecInfo(Buffer+FRecInfoOf
end;
function TMDBFTable.GetRecordSize: Word;
begin
Result:=frecsize;
end;
function TMDBFTable.AllocRecordBuff
begin
GetMem(Result, FRecBufSize);
end;
procedure TMDBFTable.FreeRecordBuffe
begin
FreeMem(Buffer, FRecBufSize);
end;
function TMDBFTable.GetRecord(Buffe
DoCheck: Boolean): TGetResult;
var
accept :Boolean;
begin
Result:=grOk;
if FData.count < 1 then
Result:=grEOF
else
repeat
case GetMode of
gmNext:
if FCurRec >= RecordCount - 1 then
result:=grEOF
else
Inc(FCurRec);
gmPrior:
if FCurRec <= 0 then
result:=grBOF
else
Dec(FCurRec);
gmCurrent:
if (FCurRec < 0) or (FCurRec >= RecordCount) then
result:=grError;
end;
if result=grOK then begin
StrLCopy(Buffer, PChar(FData[FCurRec]),frec
ClearCalcFields(Buffer);
GetCalcFields(Buffer);
with PRecInfo(Buffer+FRecInfoOf
BookmarkFlag:=bfCurrent;
Bookmark:=Integer(FData.Ob
end;
end else
if (result=grError) and DoCheck then
DatabaseError(Err_NoRecord
accept:=(fshowdeleted or (not fshowdeleted and (buffer[0]<>flgDeleted)));
if Filtered or FActiveFilter then
accept:=accept and ProcessFilter(Buffer);
if (GetMode=gmCurrent) and not Accept then
Result:=grError;
until (Result<>grOK) or Accept;
if ((Result=grEOF) or (Result=grBOF)) and (Filtered or FActiveFilter) and not (ProcessFilter(Buffer)) then
Result := grError;
end;
procedure TMDBFTable.InternalInitRec
begin
FillChar(Buffer^,RecordSiz
end;
function TMDBFTable.GetFieldData(Fi
begin
if (FData.count=0) and (fcurrec=-1) and (state=dsbrowse) then
fillchar(activeBuffer^,Rec
if not (Field.datatype in [ftmemo,ftgraphic,ftblob,f
Result:=getdata(field,pcha
else
Result:=True;
end;
procedure TMDBFTable.SetFieldData(Fi
var
Offs,fs :integer;
i,j,p :integer;
s :string;
dt :TDateTime;
eof :boolean;
begin
if (Field.FieldNo>=0) and (Assigned(Buffer)) then begin
if activebuffer[0]=#0 then
FillChar(activeBuffer^,Rec
offs:=tdbffield(FStructure
fs:=tdbffield(FStructure.f
case Field.DataType of
ftString: ;
ftFloat :begin
Str(pdouble(Buffer)^:fs:td
while Length(s)<fs do
s:=' '+s;
p:=Pos(DecimalSeparator,s)
if (p>0) and (DecimalSeparator<>'.') then
s[p]:='.';
strlcopy(buffer,PChar(s),f
end;
ftInteger, ftMemo :begin
s:=inttostr(pinteger(Buffe
while Length(s)<fs do
s:=' '+s;
strlcopy(buffer,PChar(s),f
end;
ftDate :begin
j:=pinteger(Buffer)^-69359
pdouble(@dt)^:=j;
s:=FormatDateTime('yyyymmd
StrLCopy(Buffer,PChar(s),f
end;
ftBoolean :if pboolean(Buffer)^ then
pchar(Buffer)^:='T'
else
pchar(Buffer)^:='F';
ftgraphic,ftblob :;
else
raise Exception.Create('Unexpect
end;
eof:=false;
if activebuffer[frecsize]<>#0
activebuffer[frecsize]:=#0
for i:=offs to offs+fs-1 do begin
if not eof then
eof:=(pchar(buffer)[i-offs
if not eof then
activebuffer[i]:=pchar(buf
else
activebuffer[i]:=#32;
end;
{if Field.DataType=ftMemo then
strcopy(pchar(FData[FCurRe
DataEvent(deFieldChange,Lo
end;
end;
procedure TMDBFTable.InternalFirst;
begin
FCurRec:=-1;
end;
procedure TMDBFTable.InternalLast;
begin
FCurRec:=FData.Count;
end;
procedure TMDBFTable.InternalPost;
begin
FModified:=True;
if (State=dsEdit) then begin
FData[FCurRec]:=ActiveBuff
end else begin
Inc(FLastBookmark);
if (State=dsInsert) and (FCurRec<0) then
FCurRec:=0;
FData.InsertObject(FCurRec
end;
end;
procedure TMDBFTable.InternalAddReco
begin
FModified:=True;
Inc(FLastBookmark);
if Append then
InternalLast;
FData.InsertObject(FCurRec
end;
procedure TMDBFTable.InternalDelete;
begin
{ FData.Delete(FCurRec);
if FCurRec >= FData.Count then
Dec(FCurRec);
if fcurrec=-1 then
FillChar(activeBuffer^,Rec
PChar(FData[FCurRec])[0]:=
PChar(activebuffer)[0]:=fl
Inc(FStructure.DeletedCoun
FModified:=True;
//refresh;
end;
function TMDBFTable.GetRecordCount:
begin
result:=FData.Count;
end;
function TMDBFTable.GetRecNo: Longint;
begin
UpdateCursorPos;
if (FCurRec = -1) and (RecordCount > 0) then
result:=1 else
result:=FCurRec + 1;
end;
procedure TMDBFTable.SetRecNo(Value:
begin
if (Value >= 0) and (Value < FData.Count) then
begin
FCurRec := Value - 1;
Resync([]);
end;
end;
procedure TMDBFTable.CreateTable;
var
hb :TdBaseIIIPlus_Header;
i :integer;
begin
with FAccess do begin
createfile(filename);
HB.Recordcount:=0;
HB.HeaderSize:=succ(succ(F
hb.recordsize:=1;
hb.version:=$03;
FillChar(hb.Reserved1,3,0)
FillChar(hb.LANRsvd,13,0);
FillChar(hb.Reserved2,4,0)
for i:=0 to fields.count-1 do
hb.recordsize:=hb.recordsi
fresult:=writedb3header(hb
if fresult=dbfok then begin
fresult:=writedbffielddefs
if fresult=dbfok then
fresult:=writedbFData(fiel
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
end;
function TMDBFTable.FindKey(const KeyValues: array of const): Boolean;
var
i : integer;
begin
result:=false;
for i:=0 to FData.Count-1 do
if pos(KeyValues[0].VPChar,FD
result:=true;
FCurRec := i;
resync([]);
break;
end;
end;
procedure TMDBFTable.Save;
var
bakfile :string;
begin
if fmakebackup then begin
bakfile:=changefileext(ffi
if fileexists(bakfile) then
deletefile(bakfile);
renamefile(ffilename,bakfi
end;
with FAccess do begin
Structure:=FStructure;
PackOnSave:=FPackOnSave;
SaveToFile(ffilename);
end;
FModified:=false;
end;
procedure TMDBFTable.Zap;
var
i :integer;
begin
FModified:=True;
for i:=0 to FData.count-1 do
delete;
FillChar(activeBuffer^,Rec
end;
procedure TMDBFTable.GetFields;
begin
fields:=FStructure.fields;
end;
function TMDBFTable.Locate(const KeyFields: string;
const KeyValues: Variant; Options: TLocateOptions): Boolean;
var
i,j,a,n : integer;
fn,s,k,v :string;
kv :variant;
p :pchar;
found :boolean;
begin
kv:=keyvalues;
if not varisarray(kv) then
kv:=vararrayof([keyvalues]
n:=vararrayhighbound(kv,1)
if length(trim(keyfields))>0 then begin
p:=stralloc(dBase_MaxField
result:=false;
for a:=0 to FData.count-1 do begin
j:=1;
for i:=0 to n-1 do begin
fn:=extractfieldname(keyfi
getdata(fieldbyname(fn),p,
v:=strpas(p);
if fieldbyname(fn).datatype=f
if locaseinsensitive in options then begin
s:=uppercase(v);
k:=uppercase(kv[i]);
end else begin
s:=v;
k:=kv[i];
end;
if lopartialkey in options then
found:=(pos(k,s)=1)
else
found:=(k=s);
end else
found:=(v=kv[i]);
result:=found;
if not found then
break;
end;
if result then begin
fcurrec:=a;
resync([]);
break;
end;
end;
strdispose(p);
end else
result:=false;
end;
function TMDBFTable.GetData(Field :TField; var Value :pchar; Buffer :pchar) :boolean;
var
Offs :integer;
s :string;
Buf :PChar;
i,j,l,p :integer;
d :Double;
n :integer;
dt :TDateTime;
OldDateFormat :string;
begin
Result:=false;
Buf:=Buffer;//ActiveBuffer
if (not IsEmpty) and (RecordCount>0) and (Field.FieldNo>0) and (Assigned(Buffer)) and (Assigned(Buf)) then begin
offs:=tdbffield(FStructure
case Field.DataType of
ftString: begin
l:=tdbffield(FStructure.fi
s:='';
i:=0;
while (Buf[offs+i]<>#0) and (i<l) do begin
s:=s+Buf[offs+i];
inc(i);
end;
s:=Trim(s);
s:=s+#0;
CharToOemBuff(PChar(s),val
Result:=true;
end;
ftFloat,ftInteger :begin
n:=tdbffield(FStructure.fi
s:='';
for i:=offs to offs+n-1 do
s:=s+Buf[i];
s:=Trim(s);
if s='' then
Result:=false
else begin
if Field.DataType=ftfloat then begin
p:=pos('.',s);
if (p>0) and (DecimalSeparator<>'.') then
s[p]:=DecimalSeparator;
result:=true;
try
d:=StrToFloat(s);
except
d:=0;
result:=false;
end;
PDouble(value)^:=d;
end else begin
Result:=True;
try
i:=StrToint(s);
except
i:=0;
result:=false;
end;
Pinteger(value)^:=i;
end;
end;
end;
ftDate :begin
s:='';
for j:=0 to 7 do
s:=s+Buf[offs+j];
SetLength(s,8);
if (trim(s)='') or (s='00000000') then
result:=false
else begin
s:=Copy(s,7,2)+DateSeparat
OldDateFormat:=ShortDateFo
ShortDateFormat:='dd/mm/yy
dt:=StrToDate(s);
ShortDateFormat:=OldDateFo
j:=Trunc(PDouble(@dt)^)+69
pinteger(value)^:=j;
result:=true;
end;
end;
ftBoolean :begin
result:=true;
if Buf[offs] in ['S','T','Y'] then
pboolean(value)^:=True
else
if Buf[Offs] in ['N','F'] then
pboolean(value)^:=false
else
result:=false;
end;
ftMemo,ftgraphic,ftblob,ft
n:=tdbffield(FStructure.fi
s:='';
for i:=offs to offs+n-1 do
s:=s+Buf[i];
s:=Trim(s);
if s='' then
Result:=false
else begin
Result:=True;
try
i:=StrToint(s);
except
i:=0;
result:=false;
end;
Pinteger(value)^:=i;
end;
end;
else begin
ShowMessage('Unexpected field type.');
result:=false;
end;
end;
end;
end;
procedure TMDBFTable.UnDelete;
begin
PChar(activebuffer)[0]:=fl
PChar(FData[FCurRec])[0]:=
Dec(FStructure.DeletedCoun
FModified:=True;
//refresh;
end;
function TMDBFTable.GetDeleted: Boolean;
begin
Result:=PChar(activebuffer
end;
procedure TMDBFTable.SetShowDeleted(
begin
if FShowDeleted<>Value then begin;
FShowDeleted := Value;
if Active then
refresh;
end;
end;
function TMDBFTable.GetFieldPointer
begin
Result:=Buffer;
if Buffer=nil then
exit;
inc(Result,tdbffield(FStru
end;
function TMDBFTable.GetActiveRecord
begin
if State=dsBrowse then begin
if IsEmpty then
Result:=nil
else
Result:=ActiveBuffer;
end else
Result:=ActiveBuffer;
end;
function TMDBFTable.HasMemo: boolean;
var
i :integer;
begin
result:=false;
for i:=0 to fieldcount-1 do
if originalfields[i].FieldTyp
result:=true;
break;
end;
end;
function TMDBFTable.ProcessFilter(B
var
FilterExpresion : string;
PosComp : integer;
FName : string;
FieldPos : integer;
FieldOffset : integer;
FieldValue : Variant;
TestValue : Variant;
FieldText : string;
OldShortDateFormat : string;
begin
FilterExpresion := Filter;
PosComp := Pos('<',FilterExpresion);
if PosComp=0 then
PosComp := Pos('>',FilterExpresion);
if PosComp=0 then
PosComp := Pos('=',FilterExpresion);
if PosComp=0 then begin
result:=True;
Exit;
end;
FName := Trim(Copy(FilterExpresion,
FieldPos := FieldDefs.IndexOf(FName);
FieldOffset := tdbffield(FStructure.field
if FieldPos < 0 then
Result:=True
else
if tdbffield(FStructure.field
try
FieldValue := '';
//FieldOffset := FieldOffset+1;
While (Buffer[FieldOffset]<>#0) and (Length(FieldValue)<tdbffi
FieldValue := FieldValue + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldValue := Trim(FieldValue);
TestValue := Trim(Copy(FilterExpresion,
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue)
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=Copy(TestValu
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=Copy(TestValu
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>Copy(TestValu
else
Result := (FieldValue<TestValue);
end else
Result := False;
except
Result := False;
end;
end
else
if tdbffield(FStructure.field
try
FieldText := '';
//FieldOffset := FieldOffset+1;
while (Buffer[FieldOffset]<>#0) and (Length(FieldText)<tdbffie
FieldText := FieldText + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldText := Trim(FieldText);
if Pos('.',FieldText)>0 then
FieldText[Pos('.',FieldTex
FieldValue := StrToFloat(FieldText);
if FilterExpresion[PosComp+1]
FieldText := Trim(Copy(FilterExpresion,
else
FieldText := Trim(Copy(FilterExpresion,
if Pos('.',FieldText)>0 then
FieldText[Pos('.',FieldTex
TestValue := StrToFloat(FieldText);
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue)
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=TestValue)
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=TestValue)
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>TestValue)
else
Result := (FieldValue<TestValue);
end
else
Result := False;
except
Result := False;
end;
end
else
if tdbffield(FStructure.field
OldShortDateFormat := ShortDateFormat;
try
FieldText := '';
//FieldOffset := FieldOffset+1;
while (Buffer[FieldOffset]<>#0) and (Length(FieldText)<tdbffie
FieldText := FieldText + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldText := Trim(FieldText);
FieldText := Copy(FieldText,1,4)+DateSe
ShortDateFormat := 'yyyy/mm/dd';
FieldValue := StrToDate(FieldText);
if FilterExpresion[PosComp+1]
FieldText := Trim(Copy(FilterExpresion,
else
FieldText := Trim(Copy(FilterExpresion,
FieldText := Copy(FieldText,1,4)+DateSe
TestValue := StrToDate(FieldText);
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue);
end else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=TestValue)
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=TestValue)
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>TestValue)
else
Result := (FieldValue<TestValue);
end
else
Result := False;
except
Result := False;
end;
ShortDateFormat := OldShortDateFormat;
end else
if tdbffield(FStructure.field
try
if (Buffer[FieldOffset+1]='T'
(Buffer[FieldOffset+1]='Y'
(Buffer[FieldOffset+1]='S'
FieldValue := True
else
FieldValue := False;
FieldText := Trim(Copy(FilterExpresion,
if FilterExpresion[PosComp]='
if (FieldText='T') or (FieldText='t') or
(FieldText='Y') or (FieldText='y') or
(FieldText='S') or (FieldText='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue=TestValue)
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue>=TestValue);
end else begin
if (FieldText[1]='T') or (FieldText[1]='t') or
(FieldText[1]='Y') or (FieldText[1]='y') or
(FieldText[1]='S') or (FieldText[1]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue>TestValue);
end;
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<=TestValue);
end
else
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<>TestValue);
end else begin
if (FieldText[1]='T') or (FieldText[1]='t') or
(FieldText[1]='Y') or (FieldText[1]='y') or
(FieldText[1]='S') or (FieldText[1]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<TestValue);
end;
end
else
Result := False;
except
Result := False;
end;
end
else
Result := False;
end;
function TMDBFTable.FindRecord(Rest
var
Status : Boolean;
begin
CheckBrowseMode;
DoBeforeScroll;
UpdateCursorPos;
CursorPosChanged;
try
if GoForward then begin
if Restart then
First;
if Filtered then
fActiveFilter := True;
Status := GetNextRecord;
end else begin
if Restart then
Last;
if Filtered then
fActiveFilter := True;
Status := GetPriorRecord;
end;
finally
if Filtered then
fActiveFilter := False;
end;
Result := Status;
if Result then
DoAfterScroll;
end;
procedure TMDBFTable.SetFilterActive
begin
SetFiltered(Value);
if Active then
refresh;
end;
function TMDBFTable.GetFilterActive
begin
Result:=inherited Filtered;
end;
function TMDBFTable.GetMemoData(Fie
var
TmpS :string;
Buff :array[1..512] of Char;
Flag :boolean;
Block :pinteger;
begin
if assigned(FMemofile) then
try
TmpS:='';
Flag:=false;
new(Block);
getdata(Field,PChar(block)
FMemoFile.Seek(Block^*512,
while (not Flag) do begin
if FMemoFile.Read(Buff,512)<5
Flag:=True;
if Pos(#$1A#$1A,Buff)>0 then begin
TmpS:=TmpS+Copy(Buff,1,Pos
Flag:=True;
end else
TmpS:=TmpS+Copy(Buff,1,Pos
end;
while Pos(#$8D,TmpS)>0 do
TmpS[Pos(#$8D,TmpS)]:=#$D;
Result:=TmpS;
dispose(block);
except
raise Exception.Create('Error occured while reading memo data.');
end;
end;
procedure TMDBFTable.SetMemoData(Fie
var
TmpL : Longint;
Block: pinteger;
s :string;
begin
if assigned(FMemofile) then begin
new(Block);
Block^:=DBTHeader.NextBloc
SetFieldData(Field,PChar(B
FMemoFile.Seek(-1,soFromEn
s:=#$1A#$1A;
for TmpL:=1 to Length(s) do
FMemoFile.write(s[TmpL],1)
FMemoFile.Seek(DBTHeader.N
Text:=Text+#$1A#$1A;
for TmpL:=1 to Length(Text) do
FMemoFile.Write(Text[TmpL]
inc(DBTHeader.NextBlock);
dispose(block);
FModified:=True;
end;
end;
{function TMDBFTable.GetBLOBData(Fie
var
p :pchar;
Buff :PChar;
Flag :boolean;
Block :pinteger;
begin
if assigned(FMemofile) then
try
result:=tmemorystream.crea
buff:=stralloc(512);
Flag:=false;
new(Block);
getdata(Field,PChar(block)
FMemoFile.Seek(Block^*512,
while (not Flag) do begin
if FMemoFile.Read(Buff,512)<5
Flag:=True;
p:=StrPos(Buff,#$1A#$1A);
if assigned(p) then begin
strlcopy(buff,buff,strlen(
Flag:=True;
end else begin
p:=strPos(#$1A,Buff);
strlcopy(buff,buff,strlen(
end;
end;
result.setsize(strlen(buff
result.write(buff,strlen(b
dispose(block);
strdispose(buff);
except
raise Exception.Create('Error occured while reading BLOB data.');
end;
end;
procedure TMDBFTable.SetBLOBData(Fie
begin
end;}
procedure TMDBFTable.InternalInsert;
begin
end;
function TMDBFTable.GetCodePage: word;
begin
Result:=FStructure.CodePag
end;
function TMDBFTable.GetDeletedCount
begin
Result:=FStructure.Deleted
end;
function TMDBFTable.GetEncrypted: boolean;
begin
Result:=FStructure.Encrypt
end;
function TMDBFTable.GetPackOnSave: Boolean;
begin
Result:=FAccess.PackOnSave
end;
function TMDBFTable.GetTransactionP
begin
Result:=FStructure.TransPr
end;
function TMDBFTable.GetWithMemo: Boolean;
begin
Result:=FStructure.Memo;
end;
procedure TMDBFTable.SetPackOnSave(c
begin
FAccess.PackOnSave:=Value;
end;
{ TFilenameProperty }
procedure TFilenameProperty.Edit;
var
FileOpen: TOpenDialog;
begin
FileOpen:=TOpenDialog.Crea
FileOpen.Filename:=GetValu
FileOpen.Filter:='dBase Files (*.DBF)|*.DBF|All Files (*.*)|*.*';
FileOpen.Options:=FileOpen
try
if FileOpen.Execute then
SetValue(FileOpen.Filename
finally
FileOpen.Free;
end;
end;
function TFilenameProperty.GetAttri
begin
Result:=[paDialog, paRevertable];
end;
end.
DBFView.exe
Alternatively here is the source for a component tat can read a dbf file without any DB engine support.
It reads an parses the file without the need for any additional recourses.
This code is quite old so it might need some fiddling if your are not using D6, D7
I’ve attached an demo exe so first check if you can view your file if ok give the component a try
//------------------------
unit MDBFTable;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DsgnIntf;
const
dBase_MaxRecCount = 1000000000;
dBase_MaxRecSize = 4000;
dBase_MaxFieldCount = 128;
dBase_MaxFieldWidth = 255;
dBase_MaxNumPrec = 16;
dBase_MaxMemoBytes = 16384;
dBase_MaxMemoRec = 512;
flgDeleted = #$2A;
flgUndeleted = #$20;
flgEOF = #$1A;
flgBOF = #$0D;
err_ErrorCode = 'Error code: ';
err_Warning='Warning';
err_Stop='Error';
err_BookMark='Cannot find bookmark';
err_NoRecords='No records';
err_InValidValue='Invalid value';
err_ChangeFileName='Cannot
err_IncorrectDBF='Incorrec
err_AccessOutRange='Access
err_WrongFieldDef='Wrong field definition';
err_FileNotOpen='File not open';
dBaseIIIPlus = $03;
dBaseIIIPlusMemo = $83;
type
PBoolean = ^Boolean;
TFilenameProperty = class(TStringProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
TDBFError = procedure(Sender: TObject;ErrorMsg:String) of object;
TFieldName = string[10];
TDBFBuffer = array[1..dBase_MaxRecSize]
TdBaseIIIPlus_Header = record
Version, //$03 without memo, $83 with memo
Year,
Month,
Day :Byte;
Recordcount :Longint;
HeaderSize,
RecordSize :Word;
Reserved1 :array[1..3] of Byte;
LANRsvd :array[1..13] of Byte;
Reserved2 :array[1..4] of Byte;
end;
TdBaseIVPlus_Header = record
Version, { 01234567
vvvmsssa
| || |
| || - presence of any memo file
| |- presence of an SQL table
| - presence of a dBASE IV memo
- indicate version number}
Year,
Month,
Day :Byte;
Recordcount :Longint;
HeaderSize,
RecordSize :Word;
Reserved1 :array[1..2] of Byte; //filled with 0
IncompleteTranstactionFlag
EncryptionFlag :byte; //$01 encrypted
MultiuserRsvd :array[1..12] of Byte;
MDXFlag, //$01 presence
LangDrvID :byte;
{ 001 - cp 437
002 - cp 850
100 - cp 852
102 - cp 865
101 - cp 866
104 - cp 895
200 - cp 1250
201 - cp 1251
003 - cp 1252 }
end;
TdBaseIIIPlus_Field = record
Name :array[1..10] of Char;
ClosingZero :byte;
FieldType :Char;
MemAddress :array[1..4] of Byte;
Width,
Decimals :Byte;
LAN1 :array[1..2] of Byte;
WorkAreaID :byte;
LAN2 :array[1..2] of Byte;
SetFields :byte;
Rsvd :byte;
end;
TdBaseIVPlus_Field = record
Name :array[1..10] of Char;
ClosingZero :byte;
FieldType :Char;
Rsvd1 :array[1..4] of Byte;
Width,
Decimals :Byte;
Rsvd2 :array[1..2] of Byte;
WorkAreaID :byte;
Rsvd3 :array[1..10] of Byte;
Indexed: byte;
end;
TDBTHeader = record
NextBlock :DWORD;
BlockSize :DWORD;
Reserved :array[1..504] of Char;
end;
PDBFField = ^TDBFField;
TDBFField = record
FieldName :TFieldname;
FieldType :TFieldType;
Size :word;
Decimals :Byte;
Offset :Word;
Indexed :boolean;
end;
TDBFStructure = record
FileName :string;
Year, Month, Day :Byte;
Version :byte;
RecordCount, DeletedCount :LongInt;
HeaderSize :Word;
RecordSize :Word;
MDXPresent :boolean;
Encrypted,
TransProt,
Memo, AnyMemo :boolean;
CodePage :word;
FieldCount :Word;
Data :TStringList;
Fields :TList;
end;
PRecInfo = ^TRecInfo;
TRecInfo = packed record
BookMark: integer;
UpdateStatus: TUpdateStatus;
BookmarkFlag: TBookmarkFlag;
end;
TDBFAccess = class(TPersistent)
private
FFile :TFileStream;
Fdb3Header :TdBaseIIIPlus_Header;
Fdb4Header :TdBaseIVPlus_Header;
Fdb3Field :TdBaseIIIPlus_Field;
Fdb4Field :TdBaseIVPlus_Field;
FDBF :TDBFStructure;
FResult :integer;
FOnDBFError:TDBFError;
FPackOnSave: Boolean;
FDB3 :boolean;
function CheckRange(FileSize :longint) :integer;
function CheckField(Field :TDBFField) :integer;
procedure OpenFile(const Filename :string);
procedure CreateFile(const Filename :string);
procedure CloseFile;
function ReadDBFHeader :integer;
function ReadDBFFieldDefs :integer;
function ReadDBFData :integer;
function WriteDB3Header(HB :TdBaseIIIPlus_Header) :integer;
function WriteDB4Header(HB :TdBaseIVPlus_Header) :integer;
function WriteDBFFieldDefs(AFields :TList) :integer;
function WriteDBFData(AFields :TList; AData :TStringList) :integer;
protected
procedure RaiseDBFError;
public
constructor Create;
destructor Destroy; override;
procedure LoadFromFile(const Filename :string);
procedure SaveToFile(const Filename :string);
property Structure :TDBFStructure read FDBF write FDBF;
property LastError :integer read FResult write FResult;
property OnDBFError:TDBFError read FOnDBFError write FOnDBFError;
property PackOnSave :Boolean read FPackOnSave write FPackOnSave;
property Dbase3 :boolean read FDB3 write FDB3;
end;
//PdBaseMemoRecord = ^TdBaseMemoRecord;
//TdBaseMemoRecord = array [0..dBase_MaxMemoBytes] of byte;
TMDBFTable = class(TDataset)
private
FAccess: TDBFAccess;
FStructure :TDBFStructure;
FData :tstringlist;
FRecSize, FRecBufSize: Integer;
FRecInfoOfs: Integer;
FCurRec: Integer;
FAbout, FFileName: string;
FLastBookmark: Integer;
FLastUpdate :string;
FOnDBFError:TDBFError;
FMakeBackup :Boolean;
FShowDeleted: Boolean;
FModified: Boolean;
FVersion: string;
FActiveFilter :boolean;
FMemoFile :TFileStream;
DBTHeader: TDBTHeader;
FMemoFilename :string;
function GetField(Index :integer) :TDBFField;
procedure DBFError(Sender: TObject; ErrorMsg :string);
function GetDeleted: Boolean;
procedure SetShowDeleted(const Value: Boolean);
procedure SetFilterActive(const Value: Boolean);
function GetFilterActive: Boolean;
function GetCodePage: word;
function GetDeletedCount: integer;
function GetEncrypted: boolean;
function GetPackOnSave: Boolean;
function GetTransactionProtected: boolean;
function GetWithMemo: Boolean;
procedure SetPackOnSave(const Value: Boolean);
protected
procedure SetNone(value :string);
procedure SetFilename(value :string);
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
function GetRecordSize: Word; override;
function GetFieldPointer(Buffer :PChar; Fields :TField) :PChar;
function GetActiveRecordBuffer :PChar;
procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
// procedure InternalRefresh; override;
procedure InternalClose; override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalGotoBookmark(Bookm
procedure InternalHandleException; override;
procedure InternalInitFieldDefs; override;
procedure InternalInitRecord(Buffer:
procedure InternalLast; override;
procedure InternalOpen; override;
procedure InternalPost; override;
procedure InternalInsert; override;
procedure InternalSetToRecord(Buffer
function IsCursorOpen: Boolean; override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
function GetRecordCount: Integer; override;
function GetRecNo: Integer; override;
procedure SetRecNo(Value: Integer); override;
function GetData(Field :TField; var Value :pchar; Buffer :PChar) :boolean;
function FindRecord(Restart, GoForward: Boolean): Boolean; override;
procedure Zap;
function HasMemo :boolean;
function ProcessFilter(Buffer:PChar
public
constructor Create(AOwner :TComponent); override;
procedure CreateTable(const FileName :string; Fields :TList; Dbase3 :boolean);
procedure Save;
function FindKey(const KeyValues: array of const): Boolean;
procedure GetFields(var Fields :TList);
function Locate(const KeyFields: string; const KeyValues: Variant;
Options: TLocateOptions): Boolean; override;
function GetMemoData(Field :TField): string;
procedure SetMemoData(Field :TField; Text :string);
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
{function GetBLOBData(Field :TField): TMemoryStream;
procedure SetBLOBData(Field :TField; BLOB :TMemoryStream);}
procedure Undelete;
property OriginalFields[Index :integer] :TDBFField read GetField;
property LastUpdate :string read FLastUpdate;
property Deleted :Boolean read GetDeleted;
property WithMemo :Boolean read GetWithMemo;
property DeletedCount :integer read GetDeletedCount;
property Modified :Boolean read FModified write FModified;
property Version :string read FVersion;
property CodePage :word read GetCodePage;
property TransactionProtected :boolean read GetTransactionProtected;
property Encrypted :boolean read GetEncrypted;
published
property About :string read fabout write SetNone;
property FileName: string read FFileName write SetFileName;
property MakeBackup :Boolean read FMakeBackup write FMakeBackup;
property ShowDeleted :Boolean read FShowDeleted write SetShowDeleted;
property PackOnSave :Boolean read GetPackOnSave write SetPackOnSave;
property Filter;
property Filtered :Boolean read GetFilterActive write SetFilterActive;
property Active;
property BeforeOpen;
property AfterOpen;
property BeforeClose;
property AfterClose;
property BeforeInsert;
property AfterInsert;
property BeforeEdit;
property AfterEdit;
property BeforePost;
property AfterPost;
property BeforeCancel;
property AfterCancel;
property BeforeDelete;
property AfterDelete;
property BeforeScroll;
property AfterScroll;
property OnDBFError:TDBFError read FOnDBFError write FOnDBFError;
property OnDeleteError;
property OnEditError;
property OnNewRecord;
property OnPostError;
property OnCalcFields;
end;
const
AboutInfo = 'MiTeC DBF Table 1.5 - © 1997,2002, MichaL MutL';
DBFOK = 0;
DBFIncorectFile =-1;
DBFOutOfRange =-2;
DBFWrongFieldDef=-3;
DBFInvalidValue =-4;
DBFNotOpened =-5;
DBFErrorMessages :array[0..5] of string = ('OK',Err_IncorrectDBF,
Err_AccessOutRange,
Err_WrongFieldDef,
Err_InValidValue,
Err_FileNotOpen);
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data',
RegisterPropertyEditor(Typ
end;
{TDBFAccess}
constructor TDBFAccess.Create;
begin
inherited create;
with fdbf do begin
data:=tstringlist.create;
fields:=tlist.create;
filename:='';
end;
end;
destructor TDBFAccess.Destroy;
begin
with fdbf do begin
data.free;
fields.free;
end;
inherited destroy;
end;
procedure TDBFAccess.OpenFile;
begin
if (filename<>'') and not assigned(ffile) then
ffile:=tfilestream.create(
end;
procedure TDBFAccess.CreateFile;
begin
if (filename<>'') then begin
if assigned(ffile) then begin
ffile.free;
ffile:=nil;
end;
if fileexists(filename) then
deletefile(filename);
ffile:=tfilestream.create(
end;
end;
procedure TDBFAccess.CloseFile;
begin
if assigned(ffile) then begin
ffile.free;
ffile:=nil;
end;
end;
function TDBFAccess.CheckRange;
begin
result:=dbfok;
if FileSize<(fdbf.recordcount
result:=DBFIncorectFile
else
if fdbf.recordcount>dBase_Max
result:=DBFOutOfRange
else
if fdbf.RecordSize>dBase_MaxR
result:=DBFOutOfRange
else
if fdbf.FieldCount>dBase_MaxF
result:=DBFOutOfRange;
end;
function TDBFAccess.CheckField;
begin
result:=dbfok;
with field do begin
if Size>dBase_MaxFieldWidth then
result:=DBFOutOfRange
else
case fieldType of
ftstring :if Decimals<>0 then
result:=DBFOutOfRange;
ftinteger :if (Size>30) or (Decimals<>0) then
result:=DBFOutOfRange;
ftfloat :if (Size>30) or (Decimals>size-2) then
result:=DBFOutOfRange
else
if Size+2<Decimals then
result:=DBFOutOfRange;
ftdate: if (Size<>8) or (Decimals<>0) then
result:=DBFOutOfRange;
ftboolean :if (Size<>1) or (Decimals<>0) then
result:=DBFOutOfRange;
ftmemo :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
ftblob :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
ftdbaseole :if (Size<>10) or (Decimals<>0) then
result:=DBFOutOfRange;
else
result:=DBFWrongFieldDef;
end;
end;
end;
function TDBFAccess.ReadDBFHeader;
var
buffer :byte;
begin
if assigned(ffile) then begin
try
setlasterror(0);
ffile.Seek(0,sofrombeginni
ffile.Read(Buffer,1);
ffile.Seek(0,sofrombeginni
if not(buffer in [$03..$F5]) then
result:=DBFIncorectFile
else
if buffer in [dBaseIIIPlus,dBaseIIIPlus
fdb3:=true;
ffile.Read(Fdb3Header,32);
with fdbf do begin
Year:=Fdb3Header.Year;
Month:=Fdb3Header.Month;
Day:=Fdb3Header.Day;
version:=3;
Recordcount:=Fdb3Header.Re
HeaderSize:=Fdb3Header.Hea
RecordSize:=Fdb3Header.Rec
FieldCount:=Pred(Pred(Head
mdxpresent:=false;
memo:=Fdb3Header.Version=d
anymemo:=memo;
codepage:=0;
encrypted:=false;
transprot:=false;
result:=CheckRange(ffile.S
end;
end else begin
ffile.Read(Fdb4Header,32);
fdb3:=false;
with fdbf do begin
Year:=Fdb4Header.Year;
Month:=Fdb4Header.Month;
Day:=Fdb4Header.Day;
case Fdb4Header.Version and 7 of
3 :version:=4;
else version:=5;
end;
Recordcount:=Fdb4Header.Re
HeaderSize:=Fdb4Header.Hea
RecordSize:=Fdb4Header.Rec
FieldCount:=Pred(Pred(Head
mdxpresent:=Fdb4Header.MDX
memo:=(Fdb4Header.Version and 128)=128;
anymemo:=(Fdb4Header.Versi
transprot:=Fdb4Header.Inco
encrypted:=Fdb4Header.Encr
case Fdb4Header.LangDrvID of
001 :codepage:=437;
002 :codepage:=850;
100 :codepage:=852;
102 :codepage:=865;
101 :codepage:=866;
104 :codepage:=895;
200 :codepage:=1250;
201 :codepage:=1251;
003 :codepage:=1252;
else
codepage:=0;
end;
result:=CheckRange(ffile.S
end;
end;
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.ReadDBFFieldDef
var
i,o :word;
b :byte;
Field :PDBFField;
begin
o:=1;
result:=dbfok;
if assigned(ffile) then begin
setlasterror(0);
try
ffile.Seek(32,sofrombeginn
if fdb3 then begin
for i:=1 to fdbf.FieldCount do
with fdbf do begin
new(field);
ffile.Read(Fdb3Field,32);
b:=1;
while (b<=10) and (Fdb3Field.Name[b]<>#0) do
Inc(b);
system.Move(Fdb3Field.Name
Field^.fieldName[0]:=Chr(P
if b>0 then
Field^.fieldName[0]:=Char(
case Fdb3Field.fieldType of
'C':Field^.FieldType:=ftst
'N': if Fdb3Field.Decimals>0 then
Field^.FieldType:=ftfloat
else
Field^.FieldType:=ftintege
'F':Field^.FieldType:=ftfl
'D':Field^.FieldType:=ftda
'L':Field^.FieldType:=ftbo
'M':Field^.FieldType:=ftme
'B':Field^.FieldType:=ftbl
'O':Field^.FieldType:=ftdb
end;
Field^.Size:=Fdb3Field.Wid
Field^.Decimals:=Fdb3Field
Field^.Offset:=o;
Field^.indexed:=Fdb3Field.
Inc(o,Fdb3Field.Width);
result:=CheckField(Field^)
if result=dbfok then
fields.add(field)
else
exit;
end;
end else begin
for i:=1 to fdbf.FieldCount do
with fdbf do begin
new(field);
ffile.Read(Fdb4Field,32);
b:=1;
while (b<=10) and (Fdb4Field.Name[b]<>#0) do
Inc(b);
system.Move(Fdb4Field.Name
Field^.fieldName[0]:=Chr(P
if b>0 then
Field^.fieldName[0]:=Char(
case Fdb4Field.fieldType of
'C':Field^.FieldType:=ftst
'N': if Fdb4Field.Decimals>0 then
Field^.FieldType:=ftfloat
else
Field^.FieldType:=ftintege
'F':Field^.FieldType:=ftfl
'D':Field^.FieldType:=ftda
'L':Field^.FieldType:=ftbo
'M':Field^.FieldType:=ftme
'B':Field^.FieldType:=ftbl
'O':Field^.FieldType:=ftdb
end;
Field^.Size:=Fdb4Field.Wid
Field^.Decimals:=Fdb4Field
Field^.Offset:=o;
Field^.indexed:=Fdb4Field.
Inc(o,Fdb4Field.Width);
result:=CheckField(Field^)
if result=dbfok then
fields.add(field)
else
exit;
end;
end;
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.ReadDBFData;
var
r :integer;
fbuffer :^TDBFBuffer;
begin
if assigned(ffile) then begin
ffile.seek(fDBF.HeaderSize
r:=fDBF.RecordSize;
while (ffile.position+fDBF.Recor
new(fbuffer);
r:=ffile.Read(fbuffer^,fDB
fdbf.data.add(strpas(pchar
end;
result:=dbfok;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDB3Header;
var
y,m,d :word;
begin
if assigned(ffile) then begin
result:=dbfok;
decodedate(date,y,m,d);
if y>2000 then
y:=y-2000
else
y:=y-1900;
hb.Year:=Y;
hb.Month:=M;
hb.Day:=D;
setlasterror(0);
try
ffile.Seek(0,sofrombeginni
ffile.Write(hb,32);
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDB4Header(
var
y,m,d :word;
begin
if assigned(ffile) then begin
result:=dbfok;
decodedate(date,y,m,d);
if y>2000 then
y:=y-2000
else
y:=y-1900;
hb.Year:=Y;
hb.Month:=M;
hb.Day:=D;
setlasterror(0);
try
ffile.Seek(0,sofrombeginni
ffile.Write(hb,32);
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDBFFieldDe
var
i :word;
begin
result:=dbfok;
if assigned(ffile) then begin
setlasterror(0);
try
if fdb3 then
for i:=0 to aFields.Count-1 do begin
FillChar(Fdb3Field,SizeOf(
Move(tdbffield(aFields.ite
case tdbffield(aFields.items[i]
ftstring: Fdb3Field.FieldType:='C';
ftinteger: Fdb3Field.FieldType:='N';
ftdate: Fdb3Field.FieldType:='D';
ftboolean: Fdb3Field.FieldType:='L';
ftmemo: Fdb3Field.FieldType:='M';
end;
Fdb3Field.Width:=tdbffield
Fdb3Field.Decimals:=tdbffi
Fdb3Field.SetFields:=byte(
ffile.Write(Fdb3Field,32);
end
else
for i:=0 to aFields.Count-1 do begin
FillChar(Fdb4Field,SizeOf(
Move(tdbffield(aFields.ite
case tdbffield(aFields.items[i]
ftstring: Fdb4Field.FieldType:='C';
ftinteger: Fdb4Field.FieldType:='N';
ftfloat: Fdb4Field.FieldType:='F';
ftdate: Fdb4Field.FieldType:='D';
ftboolean: Fdb4Field.FieldType:='L';
ftmemo: Fdb4Field.FieldType:='M';
ftblob: Fdb4Field.FieldType:='B';
ftdbaseole: Fdb4Field.FieldType:='O';
end;
Fdb4Field.Width:=tdbffield
Fdb4Field.Decimals:=tdbffi
Fdb4Field.Indexed:=byte(td
ffile.Write(Fdb4Field,32);
end
except
result:=getlasterror;
end;
end else
result:=dbfnotopened;
end;
function TDBFAccess.WriteDBFData;
var
fbuffer :pchar;
recsize,i :integer;
S:char;
begin
if assigned(ffile) then begin
result:=dbfok;
setlasterror(0);
recsize:=1;
for i:=0 to afields.count-1 do
recsize:=recsize+tdbffield
fbuffer:=stralloc(recsize+
try
S:=flgBOF;
ffile.write(S,1);
if assigned(adata) then begin
for i:=0 to adata.count-1 do
if not packonsave or (packonsave and (PChar(adata[i])[0]<>flgDe
StrCopy(FBuffer,PChar(adat
ffile.write(fBuffer^,recsi
end;
S:=flgEOF;
end;
ffile.write(S,1);
finally
strdispose(fbuffer);
end;
end else
result:=dbfnotopened;
end;
procedure TDBFAccess.RaiseDBFError;
var
s :string;
begin
if (fresult<0) then
s:=DBFErrorMessages[abs(fr
else
s:=Err_ErrorCode+inttostr(
if Assigned(FOnDBFError) then
FOnDBFError(Self,s);
Abort;
end;
procedure TDBFAccess.LoadFromFile;
begin
fdbf.filename:=filename;
fdbf.fields.clear;
fdbf.data.clear;
openfile(fdbf.filename);
fresult:=readdbfheader;
if fresult=dbfok then begin
fresult:=readdbffielddefs;
if fresult=dbfok then
begin
fresult:=readdbFData;
end;
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
procedure TDBFAccess.SaveToFile;
begin
createfile(filename);
if fdbf.version=3 then begin
{if fdbf.Memo then
Fdb3Header.Version:=dbasei
else
Fdb3Header.Version:=dbasei
if PackOnSave then
Fdb3Header.Recordcount:=fD
else
Fdb3Header.Recordcount:=fD
Fdb3Header.HeaderSize:=fDB
Fdb3Header.RecordSize:=fDB
fresult:=writedb3header(Fd
end else begin
{Fdb4Header.Version:=0;
Fdb4Header.Version:=Fdb4He
if fdbf.AnyMemo then
Fdb4Header.Version:=Fdb4He
if fdbf.Memo then
Fdb4Header.Version:=Fdb4He
Fdb4Header.MDXFlag:=byte(f
Fdb4Header.EncryptionFlag:
Fdb4Header.IncompleteTrans
if PackOnSave then
Fdb4Header.Recordcount:=fD
else
Fdb4Header.Recordcount:=fD
Fdb4Header.HeaderSize:=fDB
Fdb4Header.RecordSize:=fDB
fresult:=writedb4header(Fd
end;
if fresult=dbfok then begin
fresult:=writedbffielddefs
if fresult=dbfok then
fresult:=writedbFData(fdbf
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
{TMDBFTable}
constructor TMDBFTable.Create;
begin
inherited create(aowner);
faccess:=tdbfaccess.create
faccess.OnDbfError:=DBFErr
fabout:=aboutinfo;
fversion:='Unknown';
end;
function TMDBFTable.GetField;
begin
result:=tdbffield(FStructu
end;
procedure TMDBFTable.DBFError(Sender
begin
if Assigned(FOnDBFError) then
FOnDBFError(Self,ErrorMsg)
MessageBox(0,PChar(ErrorMs
end;
procedure TMDBFTable.SetFilename;
begin
if active then begin
if Assigned(FOnDBFError) then
FOnDBFError(Self,Err_Chang
else
MessageBox(0,Err_ChangeFil
end else
ffilename:=value;
end;
procedure TMDBFTable.SetNone;
begin
end;
procedure TMDBFTable.InternalOpen;
var
I: Integer;
y :word;
begin
faccess.loadfromfile(ffile
FStructure:=FAccess.Struct
FData:=FStructure.data;
FStructure.DeletedCount:=0
for I:=1 to FData.Count do begin
FData.Objects[I-1]:=Pointe
if PChar(FData[i-1])[0]=flgDe
Inc(FStructure.Deletedcoun
end;
if WithMemo then begin
try
FMemoFilename:=changefilee
FMemoFile:=TFileStream.Cre
FMemoFile.Seek(0,soFromBeg
FMemoFile.ReadBuffer(DBTHe
except
on e:exception do
showmessage(e.message);
end;
end;
fversion:='dBase ?';
case FStructure.version of
3: fversion:='dBase III+';
4: fversion:='dBase IV';
5: fversion:='dBase/Win';
end;
if FStructure.Year>50 then
y:=FStructure.Year+1900
else
y:=FStructure.Year+2000;
FLastUpdate:=datetostr(enc
FLastBookmark:=FData.Count
FCurRec:=-1;
frecsize:=1;
for i:=0 to FStructure.fields.count-1 do
frecsize:=frecsize+tdbffie
FRecInfoOfs:=frecsize;
FRecBufSize:=FRecInfoOfs+S
BookmarkSize:=SizeOf(Integ
InternalInitFieldDefs;
if DefaultFields then
CreateFields;
BindFields(True);
end;
procedure TMDBFTable.InternalClose;
begin
if Assigned(FMemoFile) then begin
FMemoFile.Free;
FMemoFile:=nil;
end;
if DefaultFields then
DestroyFields;
FLastBookmark:=0;
FCurRec:=-1;
end;
function TMDBFTable.IsCursorOpen: Boolean;
begin
result:=Assigned(FData);
end;
procedure TMDBFTable.InternalInitFie
var
i,s :integer;
begin
FieldDefs.Clear;
with FStructure.fields do
for i:=0 to FStructure.fieldcount-1 do begin
if tdbffield(items[i]^).field
s:=tdbffield(items[i]^).si
else
s:=0;
TFieldDef.Create(FieldDefs
tdbffield(items[i]^).field
end;
end;
procedure TMDBFTable.InternalHandleE
begin
Application.HandleExceptio
end;
procedure TMDBFTable.InternalGotoBoo
var
Index: Integer;
begin
Index:=FData.IndexOfObject
if Index<>-1 then
FCurRec:=Index
else
DatabaseError(Err_BookMark
end;
procedure TMDBFTable.InternalSetToRe
begin
InternalGotoBookmark(@PRec
end;
function TMDBFTable.GetBookmarkFlag
begin
Result:=PRecInfo(Buffer+FR
end;
procedure TMDBFTable.SetBookmarkFlag
begin
PRecInfo(Buffer+FRecInfoOf
end;
procedure TMDBFTable.GetBookmarkData
begin
PInteger(Data)^:=PRecInfo(
end;
procedure TMDBFTable.SetBookmarkData
begin
PRecInfo(Buffer+FRecInfoOf
end;
function TMDBFTable.GetRecordSize: Word;
begin
Result:=frecsize;
end;
function TMDBFTable.AllocRecordBuff
begin
GetMem(Result, FRecBufSize);
end;
procedure TMDBFTable.FreeRecordBuffe
begin
FreeMem(Buffer, FRecBufSize);
end;
function TMDBFTable.GetRecord(Buffe
DoCheck: Boolean): TGetResult;
var
accept :Boolean;
begin
Result:=grOk;
if FData.count < 1 then
Result:=grEOF
else
repeat
case GetMode of
gmNext:
if FCurRec >= RecordCount - 1 then
result:=grEOF
else
Inc(FCurRec);
gmPrior:
if FCurRec <= 0 then
result:=grBOF
else
Dec(FCurRec);
gmCurrent:
if (FCurRec < 0) or (FCurRec >= RecordCount) then
result:=grError;
end;
if result=grOK then begin
StrLCopy(Buffer, PChar(FData[FCurRec]),frec
ClearCalcFields(Buffer);
GetCalcFields(Buffer);
with PRecInfo(Buffer+FRecInfoOf
BookmarkFlag:=bfCurrent;
Bookmark:=Integer(FData.Ob
end;
end else
if (result=grError) and DoCheck then
DatabaseError(Err_NoRecord
accept:=(fshowdeleted or (not fshowdeleted and (buffer[0]<>flgDeleted)));
if Filtered or FActiveFilter then
accept:=accept and ProcessFilter(Buffer);
if (GetMode=gmCurrent) and not Accept then
Result:=grError;
until (Result<>grOK) or Accept;
if ((Result=grEOF) or (Result=grBOF)) and (Filtered or FActiveFilter) and not (ProcessFilter(Buffer)) then
Result := grError;
end;
procedure TMDBFTable.InternalInitRec
begin
FillChar(Buffer^,RecordSiz
end;
function TMDBFTable.GetFieldData(Fi
begin
if (FData.count=0) and (fcurrec=-1) and (state=dsbrowse) then
fillchar(activeBuffer^,Rec
if not (Field.datatype in [ftmemo,ftgraphic,ftblob,f
Result:=getdata(field,pcha
else
Result:=True;
end;
procedure TMDBFTable.SetFieldData(Fi
var
Offs,fs :integer;
i,j,p :integer;
s :string;
dt :TDateTime;
eof :boolean;
begin
if (Field.FieldNo>=0) and (Assigned(Buffer)) then begin
if activebuffer[0]=#0 then
FillChar(activeBuffer^,Rec
offs:=tdbffield(FStructure
fs:=tdbffield(FStructure.f
case Field.DataType of
ftString: ;
ftFloat :begin
Str(pdouble(Buffer)^:fs:td
while Length(s)<fs do
s:=' '+s;
p:=Pos(DecimalSeparator,s)
if (p>0) and (DecimalSeparator<>'.') then
s[p]:='.';
strlcopy(buffer,PChar(s),f
end;
ftInteger, ftMemo :begin
s:=inttostr(pinteger(Buffe
while Length(s)<fs do
s:=' '+s;
strlcopy(buffer,PChar(s),f
end;
ftDate :begin
j:=pinteger(Buffer)^-69359
pdouble(@dt)^:=j;
s:=FormatDateTime('yyyymmd
StrLCopy(Buffer,PChar(s),f
end;
ftBoolean :if pboolean(Buffer)^ then
pchar(Buffer)^:='T'
else
pchar(Buffer)^:='F';
ftgraphic,ftblob :;
else
raise Exception.Create('Unexpect
end;
eof:=false;
if activebuffer[frecsize]<>#0
activebuffer[frecsize]:=#0
for i:=offs to offs+fs-1 do begin
if not eof then
eof:=(pchar(buffer)[i-offs
if not eof then
activebuffer[i]:=pchar(buf
else
activebuffer[i]:=#32;
end;
{if Field.DataType=ftMemo then
strcopy(pchar(FData[FCurRe
DataEvent(deFieldChange,Lo
end;
end;
procedure TMDBFTable.InternalFirst;
begin
FCurRec:=-1;
end;
procedure TMDBFTable.InternalLast;
begin
FCurRec:=FData.Count;
end;
procedure TMDBFTable.InternalPost;
begin
FModified:=True;
if (State=dsEdit) then begin
FData[FCurRec]:=ActiveBuff
end else begin
Inc(FLastBookmark);
if (State=dsInsert) and (FCurRec<0) then
FCurRec:=0;
FData.InsertObject(FCurRec
end;
end;
procedure TMDBFTable.InternalAddReco
begin
FModified:=True;
Inc(FLastBookmark);
if Append then
InternalLast;
FData.InsertObject(FCurRec
end;
procedure TMDBFTable.InternalDelete;
begin
{ FData.Delete(FCurRec);
if FCurRec >= FData.Count then
Dec(FCurRec);
if fcurrec=-1 then
FillChar(activeBuffer^,Rec
PChar(FData[FCurRec])[0]:=
PChar(activebuffer)[0]:=fl
Inc(FStructure.DeletedCoun
FModified:=True;
//refresh;
end;
function TMDBFTable.GetRecordCount:
begin
result:=FData.Count;
end;
function TMDBFTable.GetRecNo: Longint;
begin
UpdateCursorPos;
if (FCurRec = -1) and (RecordCount > 0) then
result:=1 else
result:=FCurRec + 1;
end;
procedure TMDBFTable.SetRecNo(Value:
begin
if (Value >= 0) and (Value < FData.Count) then
begin
FCurRec := Value - 1;
Resync([]);
end;
end;
procedure TMDBFTable.CreateTable;
var
hb :TdBaseIIIPlus_Header;
i :integer;
begin
with FAccess do begin
createfile(filename);
HB.Recordcount:=0;
HB.HeaderSize:=succ(succ(F
hb.recordsize:=1;
hb.version:=$03;
FillChar(hb.Reserved1,3,0)
FillChar(hb.LANRsvd,13,0);
FillChar(hb.Reserved2,4,0)
for i:=0 to fields.count-1 do
hb.recordsize:=hb.recordsi
fresult:=writedb3header(hb
if fresult=dbfok then begin
fresult:=writedbffielddefs
if fresult=dbfok then
fresult:=writedbFData(fiel
end;
closefile;
if fresult<>dbfok then
raisedbferror;
end;
end;
function TMDBFTable.FindKey(const KeyValues: array of const): Boolean;
var
i : integer;
begin
result:=false;
for i:=0 to FData.Count-1 do
if pos(KeyValues[0].VPChar,FD
result:=true;
FCurRec := i;
resync([]);
break;
end;
end;
procedure TMDBFTable.Save;
var
bakfile :string;
begin
if fmakebackup then begin
bakfile:=changefileext(ffi
if fileexists(bakfile) then
deletefile(bakfile);
renamefile(ffilename,bakfi
end;
with FAccess do begin
Structure:=FStructure;
PackOnSave:=FPackOnSave;
SaveToFile(ffilename);
end;
FModified:=false;
end;
procedure TMDBFTable.Zap;
var
i :integer;
begin
FModified:=True;
for i:=0 to FData.count-1 do
delete;
FillChar(activeBuffer^,Rec
end;
procedure TMDBFTable.GetFields;
begin
fields:=FStructure.fields;
end;
function TMDBFTable.Locate(const KeyFields: string;
const KeyValues: Variant; Options: TLocateOptions): Boolean;
var
i,j,a,n : integer;
fn,s,k,v :string;
kv :variant;
p :pchar;
found :boolean;
begin
kv:=keyvalues;
if not varisarray(kv) then
kv:=vararrayof([keyvalues]
n:=vararrayhighbound(kv,1)
if length(trim(keyfields))>0 then begin
p:=stralloc(dBase_MaxField
result:=false;
for a:=0 to FData.count-1 do begin
j:=1;
for i:=0 to n-1 do begin
fn:=extractfieldname(keyfi
getdata(fieldbyname(fn),p,
v:=strpas(p);
if fieldbyname(fn).datatype=f
if locaseinsensitive in options then begin
s:=uppercase(v);
k:=uppercase(kv[i]);
end else begin
s:=v;
k:=kv[i];
end;
if lopartialkey in options then
found:=(pos(k,s)=1)
else
found:=(k=s);
end else
found:=(v=kv[i]);
result:=found;
if not found then
break;
end;
if result then begin
fcurrec:=a;
resync([]);
break;
end;
end;
strdispose(p);
end else
result:=false;
end;
function TMDBFTable.GetData(Field :TField; var Value :pchar; Buffer :pchar) :boolean;
var
Offs :integer;
s :string;
Buf :PChar;
i,j,l,p :integer;
d :Double;
n :integer;
dt :TDateTime;
OldDateFormat :string;
begin
Result:=false;
Buf:=Buffer;//ActiveBuffer
if (not IsEmpty) and (RecordCount>0) and (Field.FieldNo>0) and (Assigned(Buffer)) and (Assigned(Buf)) then begin
offs:=tdbffield(FStructure
case Field.DataType of
ftString: begin
l:=tdbffield(FStructure.fi
s:='';
i:=0;
while (Buf[offs+i]<>#0) and (i<l) do begin
s:=s+Buf[offs+i];
inc(i);
end;
s:=Trim(s);
s:=s+#0;
CharToOemBuff(PChar(s),val
Result:=true;
end;
ftFloat,ftInteger :begin
n:=tdbffield(FStructure.fi
s:='';
for i:=offs to offs+n-1 do
s:=s+Buf[i];
s:=Trim(s);
if s='' then
Result:=false
else begin
if Field.DataType=ftfloat then begin
p:=pos('.',s);
if (p>0) and (DecimalSeparator<>'.') then
s[p]:=DecimalSeparator;
result:=true;
try
d:=StrToFloat(s);
except
d:=0;
result:=false;
end;
PDouble(value)^:=d;
end else begin
Result:=True;
try
i:=StrToint(s);
except
i:=0;
result:=false;
end;
Pinteger(value)^:=i;
end;
end;
end;
ftDate :begin
s:='';
for j:=0 to 7 do
s:=s+Buf[offs+j];
SetLength(s,8);
if (trim(s)='') or (s='00000000') then
result:=false
else begin
s:=Copy(s,7,2)+DateSeparat
OldDateFormat:=ShortDateFo
ShortDateFormat:='dd/mm/yy
dt:=StrToDate(s);
ShortDateFormat:=OldDateFo
j:=Trunc(PDouble(@dt)^)+69
pinteger(value)^:=j;
result:=true;
end;
end;
ftBoolean :begin
result:=true;
if Buf[offs] in ['S','T','Y'] then
pboolean(value)^:=True
else
if Buf[Offs] in ['N','F'] then
pboolean(value)^:=false
else
result:=false;
end;
ftMemo,ftgraphic,ftblob,ft
n:=tdbffield(FStructure.fi
s:='';
for i:=offs to offs+n-1 do
s:=s+Buf[i];
s:=Trim(s);
if s='' then
Result:=false
else begin
Result:=True;
try
i:=StrToint(s);
except
i:=0;
result:=false;
end;
Pinteger(value)^:=i;
end;
end;
else begin
ShowMessage('Unexpected field type.');
result:=false;
end;
end;
end;
end;
procedure TMDBFTable.UnDelete;
begin
PChar(activebuffer)[0]:=fl
PChar(FData[FCurRec])[0]:=
Dec(FStructure.DeletedCoun
FModified:=True;
//refresh;
end;
function TMDBFTable.GetDeleted: Boolean;
begin
Result:=PChar(activebuffer
end;
procedure TMDBFTable.SetShowDeleted(
begin
if FShowDeleted<>Value then begin;
FShowDeleted := Value;
if Active then
refresh;
end;
end;
function TMDBFTable.GetFieldPointer
begin
Result:=Buffer;
if Buffer=nil then
exit;
inc(Result,tdbffield(FStru
end;
function TMDBFTable.GetActiveRecord
begin
if State=dsBrowse then begin
if IsEmpty then
Result:=nil
else
Result:=ActiveBuffer;
end else
Result:=ActiveBuffer;
end;
function TMDBFTable.HasMemo: boolean;
var
i :integer;
begin
result:=false;
for i:=0 to fieldcount-1 do
if originalfields[i].FieldTyp
result:=true;
break;
end;
end;
function TMDBFTable.ProcessFilter(B
var
FilterExpresion : string;
PosComp : integer;
FName : string;
FieldPos : integer;
FieldOffset : integer;
FieldValue : Variant;
TestValue : Variant;
FieldText : string;
OldShortDateFormat : string;
begin
FilterExpresion := Filter;
PosComp := Pos('<',FilterExpresion);
if PosComp=0 then
PosComp := Pos('>',FilterExpresion);
if PosComp=0 then
PosComp := Pos('=',FilterExpresion);
if PosComp=0 then begin
result:=True;
Exit;
end;
FName := Trim(Copy(FilterExpresion,
FieldPos := FieldDefs.IndexOf(FName);
FieldOffset := tdbffield(FStructure.field
if FieldPos < 0 then
Result:=True
else
if tdbffield(FStructure.field
try
FieldValue := '';
//FieldOffset := FieldOffset+1;
While (Buffer[FieldOffset]<>#0) and (Length(FieldValue)<tdbffi
FieldValue := FieldValue + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldValue := Trim(FieldValue);
TestValue := Trim(Copy(FilterExpresion,
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue)
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=Copy(TestValu
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=Copy(TestValu
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>Copy(TestValu
else
Result := (FieldValue<TestValue);
end else
Result := False;
except
Result := False;
end;
end
else
if tdbffield(FStructure.field
try
FieldText := '';
//FieldOffset := FieldOffset+1;
while (Buffer[FieldOffset]<>#0) and (Length(FieldText)<tdbffie
FieldText := FieldText + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldText := Trim(FieldText);
if Pos('.',FieldText)>0 then
FieldText[Pos('.',FieldTex
FieldValue := StrToFloat(FieldText);
if FilterExpresion[PosComp+1]
FieldText := Trim(Copy(FilterExpresion,
else
FieldText := Trim(Copy(FilterExpresion,
if Pos('.',FieldText)>0 then
FieldText[Pos('.',FieldTex
TestValue := StrToFloat(FieldText);
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue)
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=TestValue)
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=TestValue)
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>TestValue)
else
Result := (FieldValue<TestValue);
end
else
Result := False;
except
Result := False;
end;
end
else
if tdbffield(FStructure.field
OldShortDateFormat := ShortDateFormat;
try
FieldText := '';
//FieldOffset := FieldOffset+1;
while (Buffer[FieldOffset]<>#0) and (Length(FieldText)<tdbffie
FieldText := FieldText + Buffer[FieldOffset];
FieldOffset := FieldOffset+1;
end;
FieldText := Trim(FieldText);
FieldText := Copy(FieldText,1,4)+DateSe
ShortDateFormat := 'yyyy/mm/dd';
FieldValue := StrToDate(FieldText);
if FilterExpresion[PosComp+1]
FieldText := Trim(Copy(FilterExpresion,
else
FieldText := Trim(Copy(FilterExpresion,
FieldText := Copy(FieldText,1,4)+DateSe
TestValue := StrToDate(FieldText);
if FilterExpresion[PosComp]='
Result := (FieldValue=TestValue);
end else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue>=TestValue)
else
Result := (FieldValue>TestValue);
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
Result := (FieldValue<=TestValue)
else
if FilterExpresion[PosComp+1]
Result := (FieldValue<>TestValue)
else
Result := (FieldValue<TestValue);
end
else
Result := False;
except
Result := False;
end;
ShortDateFormat := OldShortDateFormat;
end else
if tdbffield(FStructure.field
try
if (Buffer[FieldOffset+1]='T'
(Buffer[FieldOffset+1]='Y'
(Buffer[FieldOffset+1]='S'
FieldValue := True
else
FieldValue := False;
FieldText := Trim(Copy(FilterExpresion,
if FilterExpresion[PosComp]='
if (FieldText='T') or (FieldText='t') or
(FieldText='Y') or (FieldText='y') or
(FieldText='S') or (FieldText='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue=TestValue)
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue>=TestValue);
end else begin
if (FieldText[1]='T') or (FieldText[1]='t') or
(FieldText[1]='Y') or (FieldText[1]='y') or
(FieldText[1]='S') or (FieldText[1]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue>TestValue);
end;
end
else
if FilterExpresion[PosComp]='
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<=TestValue);
end
else
if FilterExpresion[PosComp+1]
if (FieldText[2]='T') or (FieldText[2]='t') or
(FieldText[2]='Y') or (FieldText[2]='y') or
(FieldText[2]='S') or (FieldText[2]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<>TestValue);
end else begin
if (FieldText[1]='T') or (FieldText[1]='t') or
(FieldText[1]='Y') or (FieldText[1]='y') or
(FieldText[1]='S') or (FieldText[1]='s') then
TestValue := True
else
TestValue := False;
Result := (FieldValue<TestValue);
end;
end
else
Result := False;
except
Result := False;
end;
end
else
Result := False;
end;
function TMDBFTable.FindRecord(Rest
var
Status : Boolean;
begin
CheckBrowseMode;
DoBeforeScroll;
UpdateCursorPos;
CursorPosChanged;
try
if GoForward then begin
if Restart then
First;
if Filtered then
fActiveFilter := True;
Status := GetNextRecord;
end else begin
if Restart then
Last;
if Filtered then
fActiveFilter := True;
Status := GetPriorRecord;
end;
finally
if Filtered then
fActiveFilter := False;
end;
Result := Status;
if Result then
DoAfterScroll;
end;
procedure TMDBFTable.SetFilterActive
begin
SetFiltered(Value);
if Active then
refresh;
end;
function TMDBFTable.GetFilterActive
begin
Result:=inherited Filtered;
end;
function TMDBFTable.GetMemoData(Fie
var
TmpS :string;
Buff :array[1..512] of Char;
Flag :boolean;
Block :pinteger;
begin
if assigned(FMemofile) then
try
TmpS:='';
Flag:=false;
new(Block);
getdata(Field,PChar(block)
FMemoFile.Seek(Block^*512,
while (not Flag) do begin
if FMemoFile.Read(Buff,512)<5
Flag:=True;
if Pos(#$1A#$1A,Buff)>0 then begin
TmpS:=TmpS+Copy(Buff,1,Pos
Flag:=True;
end else
TmpS:=TmpS+Copy(Buff,1,Pos
end;
while Pos(#$8D,TmpS)>0 do
TmpS[Pos(#$8D,TmpS)]:=#$D;
Result:=TmpS;
dispose(block);
except
raise Exception.Create('Error occured while reading memo data.');
end;
end;
procedure TMDBFTable.SetMemoData(Fie
var
TmpL : Longint;
Block: pinteger;
s :string;
begin
if assigned(FMemofile) then begin
new(Block);
Block^:=DBTHeader.NextBloc
SetFieldData(Field,PChar(B
FMemoFile.Seek(-1,soFromEn
s:=#$1A#$1A;
for TmpL:=1 to Length(s) do
FMemoFile.write(s[TmpL],1)
FMemoFile.Seek(DBTHeader.N
Text:=Text+#$1A#$1A;
for TmpL:=1 to Length(Text) do
FMemoFile.Write(Text[TmpL]
inc(DBTHeader.NextBlock);
dispose(block);
FModified:=True;
end;
end;
{function TMDBFTable.GetBLOBData(Fie
var
p :pchar;
Buff :PChar;
Flag :boolean;
Block :pinteger;
begin
if assigned(FMemofile) then
try
result:=tmemorystream.crea
buff:=stralloc(512);
Flag:=false;
new(Block);
getdata(Field,PChar(block)
FMemoFile.Seek(Block^*512,
while (not Flag) do begin
if FMemoFile.Read(Buff,512)<5
Flag:=True;
p:=StrPos(Buff,#$1A#$1A);
if assigned(p) then begin
strlcopy(buff,buff,strlen(
Flag:=True;
end else begin
p:=strPos(#$1A,Buff);
strlcopy(buff,buff,strlen(
end;
end;
result.setsize(strlen(buff
result.write(buff,strlen(b
dispose(block);
strdispose(buff);
except
raise Exception.Create('Error occured while reading BLOB data.');
end;
end;
procedure TMDBFTable.SetBLOBData(Fie
begin
end;}
procedure TMDBFTable.InternalInsert;
begin
end;
function TMDBFTable.GetCodePage: word;
begin
Result:=FStructure.CodePag
end;
function TMDBFTable.GetDeletedCount
begin
Result:=FStructure.Deleted
end;
function TMDBFTable.GetEncrypted: boolean;
begin
Result:=FStructure.Encrypt
end;
function TMDBFTable.GetPackOnSave: Boolean;
begin
Result:=FAccess.PackOnSave
end;
function TMDBFTable.GetTransactionP
begin
Result:=FStructure.TransPr
end;
function TMDBFTable.GetWithMemo: Boolean;
begin
Result:=FStructure.Memo;
end;
procedure TMDBFTable.SetPackOnSave(c
begin
FAccess.PackOnSave:=Value;
end;
{ TFilenameProperty }
procedure TFilenameProperty.Edit;
var
FileOpen: TOpenDialog;
begin
FileOpen:=TOpenDialog.Crea
FileOpen.Filename:=GetValu
FileOpen.Filter:='dBase Files (*.DBF)|*.DBF|All Files (*.*)|*.*';
FileOpen.Options:=FileOpen
try
if FileOpen.Execute then
SetValue(FileOpen.Filename
finally
FileOpen.Free;
end;
end;
function TFilenameProperty.GetAttri
begin
Result:=[paDialog, paRevertable];
end;
end.
DBFView.exe
Borland created DBE to access easier to DBase and Paradox Database, to read dbf file you need just TTable and the following even
procedure TForm1.FormCreate(Sender: TObject);
begin
Table1.TableName := 'C:\file.dbf';
Table1.Open;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Table1.TableName := 'C:\file.dbf';
Table1.Open;
end;
hello every one
i hope ttaht you will help me. i could finally know that my .dbf file from FoxPro 6.0 and my Delphi is Delph 2007 for win 32 . can any one help me to read this data and get it from it's files
i hope ttaht you will help me. i could finally know that my .dbf file from FoxPro 6.0 and my Delphi is Delph 2007 for win 32 . can any one help me to read this data and get it from it's files
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi
From novice to tech pro — start learning today.
Experts Exchange Solution brought to you by
Enjoy your complimentary solution view.
Get every solution instantly with Premium.
Start your 7-day free trial.
Now you can add a TAdoTable, link the TADoConnection, set the tablename (from one of the list) and open.