修改的一个导出DataSet到xls的单元[1]

//首先感谢原作者，但当初在csdn上搜索到该单元时，就没原作者的信息（程序里的有些乱码的注释应该是原作者留下的吧？呵呵）
//有不足的地方还请各位看官多多指点哈 ^_^

(* modify by 角落的青苔@2005/05/13
   说明：增加导出过程中的回调功能（用户停止，进度条）
         是否在第一行插入fieldname
         改错：以前只能对word类型数值写入，dword会range check error；已修正，见cellinteger
         //这个单元原来的col和row刚好弄反了(已修正):-(
         增加导出分页的功能，因为xls单页不能超过 65536 行（采用的笨办法，不知谁有好一点的方法吗？比如直接写标记表示分页？）
*)

unit unitxlsfile;

interface

uses
  windows, messages, variants, sysutils, classes, graphics, controls, forms, dialogs,
  db,dbgrids, oleserver, excel2000;

const _msg_xlswriterisruning='有其它任务正在导出数据，暂时不能执行该操作，请稍后重试！';
type
  tusercommand=(userstop, userneedsave, usernotsave, userskip, userdonothing);
  texportxls_callbackproc = procedure(ipos:real) of object;

  tatributcell = (achidden,aclocked,acshaded,acbottomborder,actopborder,
                acrightborder,acleftborder,acleft,accenter,acright,acfill);

  tsetofatribut = set of tatributcell;

  txlswriter = class(tobject)
  private
    fstream:tfilestream;
    procedure writeword(w:word);
    procedure setcellatribut(value:tsetofatribut;var fatribut:array of byte);
  protected
    procedure writebof;
    procedure writeeof;
    procedure writedimension;
  public
    maxcols,maxrows:word;
    //add by 角落的青苔@2005/05/18
    procedure cellinteger(vrow,vcol:word;avalue:integer;vatribut:tsetofatribut=[]);
    procedure celldouble(vrow,vcol:word;avalue:double;vatribut:tsetofatribut=[]);
    procedure cellstr(vrow,vcol:word;avalue:string;vatribut:tsetofatribut=[]);
    procedure writefield(vrow,vcol:word;field:tfield);
    constructor create(vfilename:string;const vmaxcols:integer=100;const vmaxrows:integer=65534);
    destructor destroy;override;
  end;

procedure datasettoxls(ds:tdataset;fname:string);
//add by 角落的青苔@2005/05/13 //只能导出最多65536条记录
procedure dbgridtoxls(grid:tdbgrid;fname:string; bsetfieldname:boolean;callfunc:texportxls_callbackproc; baskforstop:boolean=true );
//add by 角落的青苔@2005/05/19
//突破xls单页65536行的限制，把数据分成数页
function dbgridtoxlsex(grid:tdbgrid;fname:string; bsetfieldname:boolean;callfunc:texportxls_callbackproc;const baskforstop:boolean=true; const bneedunite:boolean=true ):integer;
//将数个xls合并成一个（分页），必须保证path最后无'\'或'/'，实际已经做成线程，以免程序无响应
procedure uniteseveralxlstoone(const tmpflag, path, filename : string;const istart, iend : integer);
//procedure stringgridtoxls(grid:tstringgrid;fname:string);

var
  g_usercmd:tusercommand;
  g_xlswriterisruning : boolean; //是否有xlswriter实例在运行，因为g_usercmd是全局变量，防止被非法刷新
implementation

const
{bof}
  cbof      = $0009;
  bit_biff5 = $0800;
  bof_biff5 = cbof or bit_biff5;
{eof}
  biff_eof = $000a;
{document types}
  doctype_xls = $0010;
{dimensions}
  dimensions = $0000;

var
  cxlsbof: array[0..5] of word = ($809, 8, 0, $10, 0, 0);
  cxlseof: array[0..1] of word = ($0a, 00);
  cxlslabel: array[0..5] of word = ($204, 0, 0, 0, 0, 0);
  cxlsnumber: array[0..4] of word = ($203, 14, 0, 0, 0);
  cxlsrk: array[0..4] of word = ($27e, 10, 0, 0, 0);
  cxlsblank: array[0..4] of word = ($201, 6, 0, 0, $17);
type
  //合并数个xls为一个多页面xls的线程
  tuniteseveralxlstoonethread = class(tthread)
  private
    tmpflag : string;
    path : string;
    filename : string;
    istart : integer;
    iend : integer;
  protected
    mcompleted : boolean;
    procedure execute; override;
  public
    constructor create(const _tmpflag, _path, _filename:string;const _istart, _iend : integer);
    destructor destroy; override;
  end;

//根据strflags在fullstr最后出现的位置，将fullstr分割成两部分，取得的两部分均不包含strflags
procedure splitstrtotwopartbylastflag(const fullstr,strflags:string;var strleft,strright:string);
var ipos:integer;
begin
  ipos := lastdelimiter(strflags,fullstr);
  strleft := copy(fullstr, 1, ipos-1);
  strright := copy(fullstr, ipos+1, length(fullstr)-ipos);
end;