用Delphi编写数据报存储控件

原创 2004年02月17日 18:48:00

一、概述

在用Delphi编写数据库程序时,经常涉及到数据的导入和导出操作,如:将大型数据库中的数据存储为便携文件,以便于出外阅读;将存储在文件中的数据信息,导入到另外的数据库中;而且,通过将数据库中的数据存储为数据文件,更便于程序内部和程序间交换数据,避免通过内存交换数据的烦琐步骤,例如在笔者编写的通用报表程序中即以该控件作为数据信息传递的载体。
二、基本思路
作为数据报存储控件,应能够存储和读入数据集的基本信息(如:字段名,字段的显示名称,字段的数据类型,记录数,字段数,指定记录指定字段的当前值等),应能够提供较好的封装特性,以便于使用。
基于此,笔者利用Delphi5.0面向对象的特点,设计开发了数据报存储控件。
三、实现方法
编写如下代码单元:
unit IbDbFile;
interface
Uses Windows, SysUtils, Classes, Forms, Db, DbTables, Dialogs;
Const
Flag = '数据报-吉星软件工作室';
Type
TDsException = Class(Exception);
TIbStorage = class(TComponent)
private
FRptTitle: string; //存储数据报说明
FPageHead: string; //页头说明
FPageFoot: string; //爷脚说明
FFieldNames: TStrings; //字段名表
FStreamIndex: TStrings; //字段索引
FStream: TStream; //存储字段内容的流
FFieldCount: Integer; //字段数
FRecordCount: Integer; //记录数
FOpenFlag: Boolean; //流是否创建标志
protected
procedure Reset; //复位---清空流的内容
procedure SaveHead(ADataSet: TDataSet; Fp: TStream); //存储报表头信息
procedure LoadTableToStream(ADataSet: TDataSet); //存储记录数据
procedure IndexFields(ADataSet: TDataSet); //将数据集的字段名保存到列表中
procedure GetHead(Fp: TFileStream); //保存报表头信息
procedure GetIndex(Fp: TFileStream); //建立记录流索引
procedure GetFieldNames(Fp: TFileStream); //从流中读入字段名表
function GetFieldName(AIndex: Integer): string; //取得字段名称
function GetFieldDataType(AIndex: Integer): TFieldType;
function GetDisplayLabel(AIndex: Integer): string; //取得字段显示名称
procedure SaveFieldToStream(AStream: TStream; AField: TField); //将字段存入流中
function GetFieldValue(ARecordNo, FieldNo: Integer): string; //字段的内容
public
Constructor Create(AOwner: TComponent);
Destructor Destroy; override;
procedure Open; //创建流以准备存储数据
procedure SaveToFile(ADataSet: TDataSet; AFileName: string); //存储方法
procedure LoadFromFile(AFileName: string); //装入数据
procedure FieldStream(ARecordNo, FieldNo: Integer; var AStream: TStream);
property FieldNames[Index: Integer]: string read GetFieldName; //字段名
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(' 当前字符串无法转换为整数!', '错误',
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; //确定流是否创建的标志
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; //复位
begin
if FOpenFlag then
begin
FFieldNames.Clear;
FStreamIndex.Clear;
FStream.Size := 0;
FRptTitle := '';
FPageHead := '';
FPageFoot := '';
FFieldCount := 0;
FRecordCount := 0;
end;
end;

//-------保存数据部分
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(' 对象没有打开');
Exit;
end;
try
if FileExists(AFileName) then DeleteFile(AFileName);
Fp := TFileStream.Create(AFileName, fmCreate);
Reset;
SaveHead(ADataSet, Fp); //保存头部信息---附加说明
IndexFields(ADataSet); //将数据集的字段信息保存到FFieldName
LoadTableToStream(ADataSet); //保存数据集的数据信息
WriteAStr(Fp, FFieldNames.Text); //存储字段名信息
Ch := '@';
Fp.Write(Ch, 1);
WriteAStr(Fp, FStreamIndex.Text); //存储字段索引列表
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];
//不用FFieldNames.Values[AField.FieldName] := AField.DisplayLabel;是考虑效率
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(' 对象没有打开');
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);
//建立流的位置的索引, 索引指向: Size#0Content
FStreamIndex.Add(Id + '=' + IntToStr(FStream.Position));
//存储字段信息到流中
SaveFieldToStream(FStream, ADataSet.Fields[J]);
end;
ADataSet.Next;
end;
finally
ADataSet.EnableControls;
end;
end;

//如果一个字段的当前内容为空或者BlobSize<=0,则只写入字段大小为0, 不写入内容
procedure TIbStorage.SaveFieldToStream(AStream: TStream; AField: TField);
var
Size: Integer;
Ch: Char;
XF: TStream;
Str: string;
begin
if AField.IsBlob then
begin
//如何把一个TBlobField字段的内容存储为流
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(' 文件不存在:' + AFileName);
Exit;
end;
Fp := TFileStream.Create(AFileName, fmOpenRead);
Check := ReadAStr(Fp);
if Check <> Flag then
begin
Application.MessageBox(' 非法文件格式', '错误', 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('记录号或者字段标号越界');
Exit;
end;
if FFieldCount = 0 then Exit;
Id := Inttostr(ARecordNO) + '_' + IntToStr(FieldNo);
Pos := StrToInt(FStreamIndex.Values[Id]);
FStream.Position := Pos;
//取得字段内容的长度
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函数索引下标越界');
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; //取得字段名称
begin
//存储的字段和数据类型各占一半
if ((AIndex < 0) or (AIndex >= FFieldNames.Count div 2)) then
Application.MessageBox(' 取字段名索引越界', '程序 错误',
Mb_Ok + Mb_IconError)
else
Result := FFieldNames.Names[AIndex*2];
end;

function TIbStorage.GetFieldDataType(AIndex: Integer): TFieldType; //取得字段名称
begin
//存储的字段和数据类型各占一半
if ((AIndex < 0) or (AIndex >= FFieldNames.Count div 2)) then
Application.MessageBox(' 取字段数据类型索引越界', '程序 错误',
Mb_Ok + Mb_IconError)
else
Result := TFieldType(StrToInt(FFieldNames.Values[FFieldNames.Names[AIndex*2+1]]));
end;

function TIbStorage.GetDisplayLabel(AIndex: Integer): string; //取得字段显示名称
begin
if ((AIndex < 0) or (AIndex >= FFieldNames.Count)) then
Application.MessageBox(' 取字段名索引越界', '程序 错误',
Mb_Ok + Mb_IconError)
else
Result := FFieldNames.Values[GetFieldName(AIndex)];
end;

end.
通过测试,该控件对Ttable,Tquery, TaodTable, TadoQuery, TibTable, TibQuery等常用的数据集控件等都能较好的支持,并且具有较好的效率(测试:1100条人事记录,23个字段存储为文件约用时2秒钟)。

四、控件的基本使用方法
1.存储数据集中的数据到文件
IbStorage1.Open; //创建存储流
IbStorage1.SaveToFile(AdataSet, Afilename);
2.从文件中读出数据信息
IbStorage1.Open;
IbStorage1.LoadFromFile(AfileName);
3.对数据报存储控件中数据的访问
Value := IbStorage1.Fields[ArecNo, AfieldNo]; //字符串类型
其它略。
五、结束语
通过编写此数据报存储控件,较好地解决了数据库程序中数据的存储和交换问题,为数据库程序的开发提供了一种实用的控件。
该控件在Windows98,Delphi5开发环境下调试通过。

用Delphi编写web打印插件

做web最不好弄的就是打印了,用IE自带的打印功能不太完美,功能也不强,所以我就将fastreport 4.3报表集成到web中,实现的方法:delphi7的activex+fastreport,下面...
  • chenhuizhouhb
  • chenhuizhouhb
  • 2013年01月04日 09:59
  • 1485

Delphi 编写IC控件

编写控件的基本步骤 1.确定一个祖先类 2.创建一个组件单元 3.在新控件中添加属性、方法和事件 事件定义方法如下: type private FOnClick:TNotifyEvent ;...
  • zang141588761
  • zang141588761
  • 2016年09月19日 13:40
  • 331

关于VCL的编写 (一) 怎样编写自己的VCL控件

怎样编写自己的VCL控件       用过Delphi的朋友们,大概对Delphi的最喜欢Delphi的不是他的强类型的pascal语法,而是强大的VCL控件,本人就是一位VCL控件的爱好者。    ...
  • dreamnan
  • dreamnan
  • 2004年09月15日 13:07
  • 2238

Delphi7下面关于动态创建控件和释放的个人总结

昨天,一个网友在动态创建控件时释放出了错。他的情况是,动态创建了N个Panel,然后双击Panel就释放掉该Panel。可问题就来了,一释放就出错。然后就一顿讨论。当然也有其他的高手给出了代码,可高手...
  • www1157763637qqcom
  • www1157763637qqcom
  • 2014年01月04日 14:54
  • 3967

DelphiIE插件开发

看这篇文章就差不多了:Delphi 开发ActiveX控件(非ActiveForm) 另外要注意的是Delphi7 web deploy一次之后菜单就变灰了。Delphi6没这个问题。 html文件中...
  • shixueli
  • shixueli
  • 2014年03月12日 14:46
  • 962

Delphi 7学习开发控件(续)

继上次我们学习开发一个简单的画线控件后,基本的制作控件步骤已经清楚了,这次我们继续加深学习控件的制作。...
  • akof1314
  • akof1314
  • 2011年03月02日 11:48
  • 4326

Delphi类和组件-TObject浅析

[摘要]Delphi 中的所有类都是从 TObject 继承而来的,都具有 TObject 的所有特性,TObject 是所有类的根类,本文详细介绍TObject。 Delphi 版本: ...
  • u010569495
  • u010569495
  • 2014年10月31日 22:48
  • 206

Delphi 2010 TButtonGroup控件的使用

TButtonGroup显示在一个容器中的按钮组。使用TButtonGroup可以创建相关按钮集合。下面来学习使用这个控件,拖动Tool Palette面板的Additional类别下TButtonG...
  • akof1314
  • akof1314
  • 2011年11月08日 12:32
  • 9209

通用Delphi数据库输入控件DBPanel的实现

李晓平/河北固安华北石油职工大学 ---- 无论是开发什么样的程序,数据输入是不可缺少的。快速地生成一个美观的输入界面无疑会大大提高程序开发的效率。系统原有的控件,往往不尽人意。在delphi中,如果...
  • nm
  • nm
  • 2000年08月29日 08:04
  • 2167

用Delphi编写CGI程序(三)

用Delphi编写CGI程序(三)   也 许 各 位 读 者 感 到 CGI 程 序 有 一 种 神 秘 感, 在 这 一 部 分 将 讲 述 一 些 关 于 CGI 程 序 的 基 本 编 程 过...
  • zou5655
  • zou5655
  • 2001年07月30日 19:31
  • 635
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:用Delphi编写数据报存储控件
举报原因:
原因补充:

(最多只允许输入30个字)