1. Overview
When writing database programs in Delphi, data import and export operations are often involved, such as: storing data in a large database as portable files for easy reading outside; importing data information stored in files into another database ; Moreover, by storing the data in the database as data files, it is easier to exchange data within and between programs, and avoid the cumbersome steps of exchanging data through memory. For example, in the general report program written by the author, this control is used as data information carrier of delivery.
2. Basic ideas
As a datagram storage control, it should be able to store and read the basic information of the data set (such as: field name, field display name, field data type, number of records, number of fields, current value of the specified field in the specified record, etc.), and should Can provide better packaging characteristics for ease of use.
Based on this, the author used the object-oriented characteristics of Delphi5.0 to design and develop the datagram storage control.
3. Implementation method
Write the following code unit:
unit IbDbFile;
interface
Uses Windows, SysUtils, Classes, Forms, Db, DbTables, Dialogs;
Const
Flag = 'Datagram-Jixing Software Studio';
Type
TDsException = Class(Exception);
TIbStorage = class(TComponent)
PRivate
FRptTitle: string; //Storage datagram description
FPageHead: string; //Page header description
FPageFoot: string; //Description of feet
FFieldNames: TStrings; //Field name table
FStreamIndex: TStrings; //field index
FStream: TStream; //Stream that stores field content
FFieldCount: Integer; //Number of fields
FRecordCount: Integer; //Number of records
FOpenFlag: Boolean; // Whether the stream is created flag
protected
procedure Reset; //Reset---clear the contents of the stream
procedure SaveHead(ADataSet: TDataSet; Fp: TStream); //Storage report header information
procedure LoadTableToStream(ADataSet: TDataSet); //Storage record data
procedure IndexFields(ADataSet: TDataSet); //Save the field names of the data set into the list
procedure GetHead(Fp: TFileStream); //Save report header information
procedure GetIndex(Fp: TFileStream); //Create record stream index
procedure GetFieldNames(Fp: TFileStream); //Read the field name table from the stream
function GetFieldName(AIndex: Integer): string; //Get the field name
function GetFieldDataType(AIndex: Integer): TFieldType;
function GetDisplayLabel(AIndex: Integer): string; //Get the field display name
procedure SaveFieldToStream(AStream: TStream; AField: TField); //Save the field into the stream
function GetFieldValue(ARecordNo, FieldNo: Integer): string; //Field content
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); //Load 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 to determine whether the 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 data part
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('The object is not open');
Exit;
end;
try
if FileExists(AFileName) then DeleteFile(AFileName);
Fp := TFileStream.Create(AFileName, fmCreate);
Reset;
SaveHead(ADataSet, Fp); //Save the header information---Additional instructions
IndexFields(ADataSet); //Save the field information of the data set to FFieldName
LoadTableToStream(ADataSet); //Save the data information of the data set
WriteAStr(Fp, FFieldNames.Text); //Storage field name information
Ch := '@';
Fp.Write(Ch, 1);
WriteAStr(Fp, FStreamIndex.Text); //Storage 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];
//Not using FFieldNames.Values[AField.FieldName] := AField.DisplayLabel; is to consider 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('The object is not open');
Exit;
end;
try
ADataSet.DisableControls;
ADataSet.First;
No := 0;
FStreamIndex.Clear;
FStream.Size := 0;
While Not ADataSet.Eof do
begin
No := No + 1;
For J := 0 to ADataSet.Fields.Count - 1 do
begin
Id := Inttostr(NO) + '_' + IntToStr(J);
//Create an index of the position of the stream, the index points to: 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 content of a field is empty or BlobSize<=0, only the field size is 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 does not exist:' + 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;
ifFieldNo < 0 then
Er := True; //FieldNo := 0;
if Er then
begin
Showmessage('The record number or field label is out of bounds');
Exit;
end;
if FFieldCount = 0 then Exit;
Id := Inttostr(ARecordNO) + '_' + IntToStr(FieldNo);
Pos := StrToInt(FStreamIndex.Values[Id]);
FStream.Position := Pos;
//Get the length of the field content
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;
ifFieldNo < 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 the field name
begin
//The stored fields and data types account for half each
if ((AIndex < 0) or (AIndex >= FFieldNames.Count div 2)) then
Application.MessageBox('Field name index out of bounds', 'Program error',
Mb_Ok + Mb_IconError)
else
Result := FFieldNames.Names[AIndex*2];
end;
function TIbStorage.GetFieldDataType(AIndex: Integer): TFieldType; //Get the field name
begin
//The stored fields and data types account for half each
if ((AIndex < 0) or (AIndex >= FFieldNames.Count div 2)) then
Application.MessageBox('The field data type index is out of bounds', 'Program error',
Mb_Ok + Mb_IconError)
else
Result := TFieldType(StrToInt(FFieldNames.Values[FFieldNames.Names[AIndex*2+1]]));
end;
function TIbStorage.GetDisplayLabel(AIndex: Integer): string; //Get the field display name
begin
if ((AIndex < 0) or (AIndex >= FFieldNames.Count)) then
Application.MessageBox('Field name index out of bounds', 'Program error',
Mb_Ok + Mb_IconError)
else
Result := FFieldNames.Values[GetFieldName(AIndex)];
end;
end.
Through testing, this control has good support for commonly used data set controls such as Ttable, Tquery, TaodTable, TadoQuery, TibTable, TibQuery, etc., and has good efficiency (test: 1100 personnel records, 23 fields stored as file takes approximately 2 seconds).
4. Basic usage of controls
1. Store data from a dataset to a file
IbStorage1.Open; //Create a storage stream
IbStorage1.SaveToFile(AdataSet, Afilename);
2. Read data information from the file
IbStorage1.Open;
IbStorage1.LoadFromFile(AfileName);
3. Access to data in the datagram storage control
Value := IbStorage1.Fields[ArecNo, AfieldNo]; //String type
Others are omitted.
5. Conclusion
By writing this datagram storage control, the problem of data storage and exchange in database programs is better solved, and a practical control is provided for the development of database programs.
The control passed debugging under Windows98 and Delphi5 development environment.