用Delphi編寫數據報存儲控件

一概述
　　
　　在用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
　　AStreamRead(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
　　ApplicationMessageBox( 當前字符串無法轉換為整數! 錯誤
　　Mb_Ok + Mb_IconError);
　　end;
　　end;
　　
　　
　　procedure WriteAStr(AStream: TStream; AStr: string);
　　begin
　　AStreamWrite(Pointer(AStr)^ Length(AStr) + );
　　end;
　　
　　procedure WriteBStr(AStream: TStream; AStr: string);
　　begin
　　AStreamWrite(Pointer(AStr)^ Length(AStr));
　　end;
　　
　　procedure WriteAInteger(AStream: TStream; AInteger: Integer);
　　var
　　S : string;
　　begin
　　S := IntToStr(AInteger);
　　WriteAstr(AStream S);
　　end;
　　
　　Constructor TIbStorageCreate(AOwner: TComponent);
　　begin
　　inherited Create(AOwner);
　　FOpenFlag := False; //確定流是否創建的標志
　　end;
　　
　　Destructor TIbStorageDestroy;
　　begin
　　if FOpenFlag then
　　begin
　　FStreamFree;
　　FStreamIndexFree;
　　FFieldNamesFree;
　　end;
　　inherited Destroy;
　　end;
　　
　　procedure TIbStorageOpen;
　　begin
　　FOpenFlag := True;
　　FStream := TMemoryStreamCreate;
　　FStreamIndex := TStringListCreate;
　　FFieldNames := TStringListCreate;
　　Reset;
　　end;
　　
　　procedure TIbStorageReset; //復位
　　begin
　　if FOpenFlag then
　　begin
　　FFieldNamesClear;
　　FStreamIndexClear;
　　FStreamSize := ;
　　FRptTitle := ;
　　FPageHead := ;
　　FPageFoot := ;
　　FFieldCount := ;
　　FRecordCount := ;
　　end;
　　end;
　　
　　//保存數據部分
　　procedure TIbStorageSaveToFile(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 := TFileStreamCreate(AFileName fmCreate);
　　Reset;
　　SaveHead(ADataSet Fp); //保存頭部信息附加說明
　　IndexFields(ADataSet); //將數據集的字段信息保存到FFieldName
　　LoadTableToStream(ADataSet); //保存數據集的數據信息
　　WriteAStr(Fp FFieldNamesText); //存儲字段名信息
　　Ch := @;
　　FpWrite(Ch );
　　WriteAStr(Fp FStreamIndexText); //存儲字段索引列表
　　Ch := @;
　　FpWrite(Ch );
　　FpCopyFrom(FStream );
　　finally
　　FpFree;
　　end;
　　end;
　　
　　procedure TIbStorageSaveHead(ADataSet: TDataSet; Fp: TStream);
　　Var
　　I : Integer;
　　Ch: Char;
　　begin
　　if Not ADataSetActive then ADataSetActive := True;
　　WriteAStr(Fp Flag);
　　WriteAStr(Fp FRptTitle);
　　WriteAStr(Fp FPageHead);
　　WriteAStr(Fp FPag
From:http://tw.wingwit.com/Article/program/Delphi/201311/8408.html