Writing a datagram Storage Control with Delphi

I. Overview

When you write a database program with Delphi, often involves importing and exporting data, such as storing data from a large database as a portable file for easy reading, importing data stored in a file into another database, and, by storing the data in the database as a data file, It is easier to exchange data between programs and programs, to avoid the tedious steps of exchanging data through memory, for example, in the general report program written by the author, the control is used as the carrier of data information transmission.

Second, the basic idea

As a datagram store control, you should be able to store and read basic information about a dataset (such as Field name, field display name, field data type, number of records, number of fields, specify the current value of the specified field, etc.), and should be able to provide better encapsulation characteristics for easy use.

Based on this, the author designed and developed the data store control by using the Delphi5.0 object-oriented features.

Iii. Methods of implementation

Write the following code unit:

Unit ibdbfile;
Interface
Uses Windows, Sysutils, Classes, Forms, Db, Dbtables, Dialogs;
Const
Flag = ' Datagram-ji-xing software studio ';
Type
Tdsexception = Class (Exception);
Tibstorage = Class (Tcomponent)
Private
frpttitle:string; Storage Datagram Description
fpagehead:string; Page Header Description
fpagefoot:string; My foot description
Ffieldnames:tstrings; Field Name table
Fstreamindex:tstrings; Field index
Fstream:tstream; A stream that stores the contents of a field
Ffieldcount:integer; Number of fields
Frecordcount:integer; Number of records
Fopenflag:boolean; Whether the stream creates a flag
Protected
Procedure Reset; Reset---The contents of the purge stream
Procedure Savehead (Adataset:tdataset; Fp:tstream); Store Report Header information
Procedure Loadtabletostream (Adataset:tdataset); Storing record data
Procedure Indexfields (Adataset:tdataset); Save the field name of the dataset to the list
Procedure GetHead (Fp:tfilestream); Save Report Header information
Procedure GetIndex (Fp:tfilestream); Establish a record flow index
Procedure Getfieldnames (Fp:tfilestream); Read the field name table from the stream
function GetFieldName (Aindex:integer): string; Get field Name
function Getfielddatatype (Aindex:integer): Tfieldtype;
function Getdisplaylabel (Aindex:integer): string; Get field Display Name
Procedure Savefieldtostream (Astream:tstream; Afield:tfield); To deposit a field in a stream
function GetFieldValue (Arecordno, Fieldno:integer): string; The contents of the field
Public
Constructor Create (aowner:tcomponent);
destructor Destroy; Override
Procedure Open; Create a stream to prepare to store data
Procedure SaveToFile (Adataset:tdataset; afilename:string); Storage method
Procedure LoadFromFile (afilename:string); Loading data
Procedure Fieldstream (Arecordno, Fieldno:integer; var astream:tstream);
Property Fieldnames[index:integer]: string read getfieldname; Field name
Property Fielddatatypes[index:integer]: Tfieldtype read getfielddatatype;
Property Fielddisplaylabels[index:integer]: string read Getdisplaylabel;
Property Fields[recno, Fieldindex:integer]: string read getfieldvalue;
Property Fieldstreams[recno, Fieldindex:integer]: Tstream read getfieldstream;
Property Recordcount:integer read Frecordcount write Frecordcount;
Property Fieldcount:integer read Ffieldcount write Ffieldcount;
Published
Property rpttitle:string read Frpttitle write frpttitle;
Property pagehead:string read Fpagehead write fpagehead;
Property pagefoot:string read Fpagefoot write fpagefoot;
End
function Readachar (astream:tstream): Char;
function Readastr (astream:tstream): string;
function Readbstr (astream:tstream; Size:integer): string;
function Readainteger (astream:tstream): Integer;
Procedure Writeastr (Astream:tstream; astr:string);
Procedure Writebstr (Astream:tstream; astr:string);
Procedure Writeainteger (Astream:tstream; Ainteger:integer);
Procedure Register;
Implementation
Procedure Register;
Begin
Registercomponents (' Data Access ', [tibstorage]);
End
function Readachar (astream:tstream): Char;
Var
Achar:char;
Begin
Astream.read (Achar, 1);
Result: = Achar;
End
function Readastr (astream:tstream): string;
Var
str:string;
C:char;
Begin
STR: = ';
C: = Readachar (Astream);
While C <> #0 do
Begin
str: = str + C;
C: = Readachar (Astream);
End
Result: = STR;
End
function Readbstr (astream:tstream; Size:integer): string;
Var
str:string;
C:char;
I:integer;
Begin
STR: = ';
For I: = 1 to Size do
Begin
C: = Readachar (Astream);
str: = str + C;
End
Result: = STR;
End
function Readainteger (astream:tstream): Integer;
Var
str:string;
C:char;
Begin
Result: = Maxint;
STR: = ';
C: = Readachar (Astream);
While C <> #0 do
Begin
str: = str + C;
C: = Readachar (Astream);
End
Try
Result: = Strtoint (STR);
Except
Application.messagebox (' The current string cannot be converted to an integer! ', ' ERROR ',
MB_OK + mb_iconerror);
End
End
Procedure Writeastr (Astream:tstream; astr:string);
Begin
Astream.write (pointer (AStr) ^, Length (ASTR) + 1);
End
Procedure Writebstr (Astream:tstream; astr:string);
Begin
Astream.write (pointer (AStr) ^, Length (AStr));
End
Procedure Writeainteger (Astream:tstream; Ainteger:integer);
Var
s:string;
Begin
S: = IntToStr (Ainteger);
Writeastr (Astream, S);
End
Constructor Tibstorage.create (aowner:tcomponent);
Begin
Inherited Create (Aowner);
Fopenflag: = False; Flag that determines whether a stream is created
End
destructor Tibstorage.destroy;
Begin
If Fopenflag Then
Begin
Fstream.free;
Fstreamindex.free;
Ffieldnames.free;
End
Inherited Destroy;
End
Procedure Tibstorage.open;
Begin
Fopenflag: = True;
FStream: = tmemorystream.create;
Fstreamindex: = tstringlist.create;
Ffieldnames: = tstringlist.create;
Reset;
End
Procedure Tibstorage.reset; Reset
Begin
If Fopenflag Then
Begin
Ffieldnames.clear;
Fstreamindex.clear;
Fstream.size: = 0;
Frpttitle: = ';
Fpagehead: = ';
Fpagefoot: = ';
Ffieldcount: = 0;
Frecordcount: = 0;
End
End
-------Save the data section
Procedure Tibstorage.savetofile (Adataset:tdataset; afilename:string);
Var
Fp:tfilestream;
I:integer;
Ch:char;
T1, T2:tdatetime;
str:string;
Begin
If not Fopenflag then
Begin
ShowMessage (' Object not open ');
Exit;
End
Try
If FileExists (afilename) then DeleteFile (afilename);
Fp: = Tfilestream.create (Afilename, fmcreate);
Reset;
Savehead (Adataset, Fp); Save Header Information---additional instructions
Indexfields (Adataset); To save the data set's field information to Ffieldname
Loadtabletostream (Adataset); Saving data information for a dataset
Writeastr (Fp, Ffieldnames.text); Store Field name information
Ch: = ' @ ';
Fp.write (Ch, 1);
Writeastr (Fp, Fstreamindex.text); Store field index List
Ch: = ' @ ';
Fp.write (Ch, 1);
Fp.copyfrom (fstream, 0);
Finally
Fp.free;
End
End
Procedure Tibstorage.savehead (Adataset:tdataset; Fp:tstream);
Var
I:integer;
Ch:char;
Begin
If not adataset.active then adataset.active: = True;
Writeastr (Fp, Flag);
Writeastr (Fp, frpttitle);
Writeastr (Fp, Fpagehead);
Writeastr (Fp, fpagefoot);
Ffieldcount: = ADataSet.Fields.Count;
Frecordcount: = Adataset.recordcount;
Writeastr (Fp, IntToStr (ADataSet.Fields.Count));
Writeastr (Fp, IntToStr (Adataset.recordcount));
Ch: = ' @ ';
Fp.write (Ch, 1);
End
Procedure Tibstorage.indexfields (Adataset:tdataset);
Var
I:integer;
Afield:tfield;
Begin
For I: = 0 to Adataset.fields.count-1 do
Begin
Afield: = Adataset.fields[i];
No Ffieldnames.values[afield.fieldname]: = Afield.displaylabel; it's about efficiency.
Ffieldnames.add (afield.fieldname + ' = ' + Afield.displaylabel);
Ffieldnames.add (afield.fieldname + ' datatype= ' + inttostr (Ord (Afield.datatype)));
End
End
Procedure Tibstorage.loadtabletostream (Adataset:tdataset);
Var
No:integer;
I, J, Size:integer;
TMP, Id, str:string; Id=string (RECNO) + string (Fieldno)
Len:integer;
Ch:char;
Blobstream:tblobstream;
Begin
If not Fopenflag then
Begin
ShowMessage (' Object not open ');
Exit;
End
Try
Adataset.disablecontrols;
Adataset.first;
No: = 0;
Fstreamindex.clear;
Fstream.size: = 0;
While does adataset.eof do
Begin
No: = no + 1;
For J: = 0 to Adataset.fields.count-1 do
Begin
Id: = IntToStr (NO) + ' _ ' + inttostr (J);
Index of the location where the stream was established, index pointing: size#0content
Fstreamindex.add (Id + ' = ' + inttostr (fstream.position));
Store field information into the stream
Savefieldtostream (FStream, adataset.fields[j]);
End
Adataset.next;
End
Finally
Adataset.enablecontrols;
End
End
If the current contents of a field are empty or blobsize<=0, only the field size is written to 0 and no content is written
Procedure Tibstorage.savefieldtostream (Astream:tstream; Afield:tfield);
Var
Size:integer;
Ch:char;
Xf:tstream;
str:string;
Begin
If Afield.isblob Then
Begin
How to store the contents of a Tblobfield field as a stream
Xf: = Tblobstream.create (Tblobfield (afield), bmread);
Try
If xf.size > 0 Then
Begin
Size: = xf.size;
Writeainteger (Astream, Size);
Astream.copyfrom (Xf, xf.size);
End
Else
Writeainteger (astream, 0);
Finally
XF. Free;
End
End
Else
Begin
STR: = afield.asstring;
Size: = Length (STR);
Writeainteger (Astream, Size);
If Size <> 0 Then
Astream.write (pointer (Str) ^, Size);
Writeastr (Astream, STR);
End
Ch: = ' @ ';
Astream.write (Ch, 1);
End
------------Load Data
Procedure Tibstorage.loadfromfile (afilename:string);
Var
Fp:tfilestream;
check:string;
Begin
Reset;
Try
If not fileexists (Afilename) Then
Begin
ShowMessage (' File not present: ' + Afilename ');
Exit;
End
Fp: = Tfilestream.create (Afilename, Fmopenread);
Check: = Readastr (Fp);
If Check <> Flag Then
Begin
Application.messagebox (' Illegal file format ', ' Error ', MB_OK + mb_iconerror);
Exit;
End
GetHead (FP);
Getfieldnames (FP);
GetIndex (FP);
Fstream.copyfrom (Fp, fp.size-fp.position);
Finally
Fp.free;
End
End
Procedure Tibstorage.gethead (Fp:tfilestream);
Begin
Frpttitle: = Readastr (Fp);
Fpagehead: = Readastr (Fp);
Fpagefoot: = Readastr (Fp);
Ffieldcount: = Readainteger (Fp);
Frecordcount: = Readainteger (Fp);
If Readachar (Fp) <> ' @ ' then ShowMessage (' GetHead File Error ');
End
Procedure Tibstorage.getfieldnames (Fp:tfilestream);
Var
Ch:char;
str:string;
Begin
STR: = ';
STR: = Readastr (Fp);
Ffieldnames.commatext: = STR;
Ch: = Readachar (Fp);
If Ch <> ' @ ' then showmessage (' When get FieldNames Error ');
End
Procedure Tibstorage.getindex (Fp:tfilestream);
Var
Ch:char;
str:string;
Begin
STR: = ';
STR: = Readastr (Fp);
Fstreamindex.commatext: = STR;
Ch: = Readachar (Fp);
If Ch <> ' @ ' then showmessage (' When get Field Position Index Error ');
End
---------Read Field ' s Value part
function Tibstorage.getfieldvalue (Arecordno, Fieldno:integer): string;
Var
Id, t:string;
Pos:integer;
Len, I:integer;
Er:boolean;
Begin
Result: = ';
Er: = False;
If Arecordno > Frecordcount Then
Er: = true; Arecordno: = Frecordcount;
If Arecordno < 1 Then
Er: = True; Arecordno: = 1;
If Fieldno >= Ffieldcount Then
Er: = True; Fieldno: = FFieldCount-1;
If Fieldno < 0 Then
Er: = True; Fieldno: = 0;
If Er Then
Begin
ShowMessage (' Record number or field marking out of bounds ');
Exit;
End
If Ffieldcount = 0 then Exit;
Id: = IntToStr (Arecordno) + ' _ ' + inttostr (fieldno);
Pos: = Strtoint (Fstreamindex.values[id]);
Fstream.position: = Pos;
Gets the length of the field's contents
Len: = Readainteger (FStream);
If Len > 0 Then
Result: = Readbstr (FStream, Len);
If Readachar (fstream) <> ' @ ' then
ShowMessage (' When Read Field, find Save Format Error ');
End
Procedure Tibstorage.fieldstream (Arecordno, Fieldno:integer; var astream:tstream);
Var
Id, t:string;
Pos:integer;
Len, I:integer;
Er:boolean;
Begin
Er: = False;
If Arecordno > Frecordcount Then
Er: = true; Arecordno: = Frecordcount;
If Arecordno < 1 Then
Er: = True; Arecordno: = 1;
If Fieldno >= Ffieldcount Then
Er: = True; Fieldno: = FFieldCount-1;
If Fieldno < 0 Then
Er: = True; Fieldno: = 0;
If Er Then
Begin
Tdsexception.create (' GetFieldValue function index subscript out of bounds ');
Exit;
End
If Ffieldcount = 0 then Exit;
Id: = IntToStr (Arecordno) + inttostr (Fieldno);
Pos: = Strtoint (Fstreamindex.values[id]);
Fstream.position: = Pos;
Len: = Readainteger (FStream);
Astream.copyfrom (FStream, Len);
End
function Tibstorage.getfieldname (Aindex:integer): string; Get field Name
Begin
Half of the fields and data types stored
if ((Aindex < 0) or (aindex >= ffieldnames.count Div 2)) then
Application.messagebox (' Take field name index out of bounds ', ' Bug ',
MB_OK + mb_iconerror)
Else
Result: = Ffieldnames.names[aindex*2];
End
function Tibstorage.getfielddatatype (Aindex:integer): Tfieldtype; Get field Name
Begin
Half of the fields and data types stored
if ((Aindex < 0) or (aindex >= ffieldnames.count Div 2)) then
Application.messagebox (' Take field data type index out of bounds ', ' Bug ',
MB_OK + mb_iconerror)
Else
Result: = Tfieldtype (Strtoint (ffieldnames.values[ffieldnames.names[aindex*2+1]));
End
function Tibstorage.getdisplaylabel (Aindex:integer): string; Get field Display Name
Begin
if ((Aindex < 0) or (aindex >= ffieldnames.count)) Then
Application.messagebox (' Take field name index out of bounds ', ' Bug ',
MB_OK + mb_iconerror)
Else
Result: = Ffieldnames.values[getfieldname (Aindex)];
End End.

Through testing, the control of Ttable,tquery, Taodtable, Tadoquery, tibtable, tibquery and other commonly used data set control, etc. can be better supported, and has a good efficiency (test: 1100 Personnel records, 23 fields are stored as files approximately 2 seconds.