用Delphi编写数据报存储控件

Posted 2023-04-16

参考技术A 一 概述　　　　在用Delphi编写数据库程序时 经常涉及到数据的导入和导出操作 如 将大型数据库中的数据存储为便携文件 以便于出外阅读 将存储在文件中的数据信息 导入到另外的数据库中 而且 通过将数据库中的数据存储为数据文件 更便于程序内部和程序间交换数据 避免通过内存交换数据的烦琐步骤 例如在笔者编写的通用报表程序中即以该控件作为数据信息传递的载体 　　　　二 基本思路　　　　作为数据报存储控件 应能够存储和读入数据集的基本信息（如 字段名 字段的显示名称 字段的数据类型 记录数 字段数 指定记录指定字段的当前值等） 应能够提供较好的封装特性 以便于使用 　　基于此 笔者利用Delphi 面向对象的特点 设计开发了数据报存储控件 　　　　三 实现方法　　　　编写如下代码单元 　　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 );　　Result := AChar;　　end;　　　　function ReadAStr(AStream: TStream): string;　　var　　Str: String;　　C : Char;　　begin　　Str := ;　　C := ReadAChar(AStream);　　While C <> # 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 := 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 <> # 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) + );　　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 := ;　　FRptTitle := ;　　FPageHead := ;　　FPageFoot := ;　　FFieldCount := ;　　FRecordCount := ;　　end;　　end;　　　　// 保存数据部分　　procedure TIbStorage SaveToFile(ADataSet: TDataSet; AFileName: string);　　var　　Fp: TFileStream;　　I : Integer;　　Ch: Char;　　T T : 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 );　　WriteAStr(Fp FStreamIndex Text); //存储字段索引列表　　Ch := @ ;　　Fp Write(Ch );　　Fp CopyFrom(FStream );　　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 FPag lishixinzhi/Article/program/Delphi/201311/8408

Delphi编写自定义控件以及接口的使用（做了一个TpgDbEdit）

写给觉得自己编写Delphi很复杂的人，包括自己。

Delphi自己写控件其实并不难，难的在于开发复杂的控件。（其实，编程，很多东西都是会了就不难，因此，我怕自己日后觉得自己写控件很难，特意在这记录自己写控件的过程，顺便也写下接口的使用）

第一步：控件代码：

下面是控件的一个Unit内容：

 

代码

unit pgdbedit;

interface

uses
  SysUtils, Classes, Controls, StdCtrls, CnEdit;

const
  IID_pgDBConInterface=\'{88CEA70D-0506-4CC0-ABB0-4BDBFA0DDBCE}\';


type
  TdbType = (dbText, dbInteger, dbFloat, dbBit, dbTime, dbBlob); //文本类型

  IpgDBConInterface = interface(IInterface) //定义数据库操作控件的接口
    [IID_pgDBConInterface]
    //Stdcall是指示函数的参数入栈方式是从右到左
    function GetCanUpdate: Boolean;
    procedure SetCanUpdate(value: Boolean);
    property DB_canUpdate: Boolean read GetCanUpdate write SetCanUpdate; //是否更新数据。
  end;
  TpgDbEdit = class(TEdit, IpgDBConInterface)
  private
    { Private declarations }
    FCanUpdate: Boolean;
    function GetCanUpdate: Boolean;
    procedure SetCanUpdate(value: Boolean);
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    property DB_canUpdate: Boolean read GetCanUpdate write SetCanUpdate; //是否更新数据。

implementation

function tpgdbedit.GetCanUpdate: Boolean;
begin
  Result:=FCanUpdate;
end;

procedure tpgdbedit.SetCanUpdate(value: Boolean);
begin
  FCanUpdate:=value;
end;
end.

 

 

说明：这里没有RegisterComponents是因为打算创建2个包，一个是运行时的包以及设计时的包。

 

第二步：创建注册单元：

下面是这个单元的源码：

 

代码

unit pgControlsRegister;

interface
uses
  Classes;

procedure Register;
{* 控件、组件编辑器、属性编辑器注册过程}

implementation

uses
  pgdbedit;

procedure Register;
begin
  RegisterComponents(\'pgControls\', [TpgDbEdit]);
end;

end.

 

 

第三步：创建运行时的包：

（文件->新建->其它->Package）

在创建出来的Package中点上面的Add按钮，把第一步中的单元添加进去，然后点上面的Options按钮，在Usage Options中选择Runtime only。点击OK关闭掉Options，然后点Compile进行编译，系统会提示需要加入其它包的，点确认就行了，系统会自动添加必要的包。这样，运行时的包就创建完了。

 

第四步：创建设计时的包：

（文件->新建->其它->Package）

在创建出来的Package中点上面的Add按钮，把第二步中的单元添加进去，然后点上面的Options按钮，在Usage Options中选择Designtime only。点击OK关闭掉Options，然后点Compile进行编译，系统会提示需要加入其它包的，点确认就行了，系统会自动添加必要的包。这样，设计时的包就创建完了。

 

有关这两个包的概念，大家可以去：

http://www.cnpack.org/showdetail.php?id=510&lang=zh-cn

看下介绍，我都是看了介绍才知道，才会去这样弄。这里，我们也是安装设计时的包就行了。运行时的包不用管。

原创作品出自努力偷懒，转载请说明文章出处：http://www.cnblogs.com/kfarvid/

http://www.cnblogs.com/kfarvid/archive/2010/08/05/1793219.html