用Delphi编写数据报存储控件

一、概括 在用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开拓情况下调节和测试经过。