作者：未知 来源：月光软件站 加入时间：2005-6-5　月光软件站

//首先感谢原作者，但当初在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;

constructor TUniteSeveralXLSToOneThread.Create(const _TmpFlag, _Path, _FileName:String;const _iStart, _iEnd : Integer);
begin
  inherited Create(True);
  TmpFlag := _TmpFlag;
  Path := _Path;
  FileName := _FileName;
  iStart := _iStart;
  iEnd := _iEnd;
  mCompleted := False;
  Resume();
end;

destructor TUniteSeveralXLSToOneThread.Destroy;
begin
  inherited;
end;

procedure TUniteSeveralXLSToOneThread.Execute;
const
  _HeadLetterOfXls:Array [1..52]of String    //注意这里只定义了52列，需要增加就自己动手，最多256列
            = ('A','B','C','D','E','F','G','H','I','J','K','L','M',
               'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
               'AA','AB','AC','AD','AE','AF','AG','AH','AI','AJ','AK','AL','AM',
               'AN','AO','AP','AQ','AR','AS','AT','AU','AV','AW','AX','AY','AZ');
  _XlsResCaption= 'FKULWJS_SKSLA_892x_RES';
  _XlsTmpCaption= 'FKULWJS_SKSLA_892x_TMP';
var
  XlsAppRes, XlsAppTmp: TExcelApplication;
  wkBookRes, wkBookTmp : _WorkBook;
  wkSheetRes, wkSheetTmp : _WorkSheet;
  LCID_Res, LCID_Tmp:Integer;
  Pos_LeftTop, Pos_RightBottom : String; //Xls中左上、右下位置
  XlsAppHwnd:THandle;
  bDontSave : Boolean;
  i : Integer;

  StrName,StrExt:String; //文件名及扩展名
begin
  FreeOnTerminate := True;
  if Terminated then Exit;
  SplitStrToTwoPartByLastFlag(FileName, '.', StrName, StrExt);
  try
    Screen.Cursor := crHourGlass;
    bDontSave := False;
    XlsAppRes := TExcelApplication.Create(Nil);
    with XlsAppRes do
    begin
      Connect;
      Visible[0]:=False;
      LCID_Res:=GetUserDefaultLCID();
      DisplayAlerts[LCID_Res]:=False;
      Caption:=_XlsResCaption;
      wkBookRes:=WorkBooks.Add(EmptyParam,LCID_Res);
    end;
    XlsAppTmp := TExcelApplication.Create(Nil);
    with XlsAppTmp do
    begin
      Connect;
      Visible[0]:=False;
      LCID_Tmp :=GetUserDefaultLCID();
      DisplayAlerts[LCID_Tmp]:=False;
      Caption:=_XlsTmpCaption;
    end;
    for i:=iStart to iEnd do
    begin
      if i<=3 then wkSheetRes:=wkBookRes.Sheets[i] as _WorkSheet
      else
      begin
        wkBookRes.Sheets.Add(EmptyParam, wkSheetRes, 1, EmptyParam, LCID_Res);
        wkSheetRes := wkBookRes.Sheets[i] as _WorkSheet;
      end;
      wkBookTmp:= XlsAppTmp.WorkBooks.Open(Path+'\'+TmpFlag+IntToStr(i)+FileName, EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,LCID_Tmp);
      Pos_LeftTop := 'A1';
      wkSheetTmp := XlsAppTmp.ActiveSheet as _WorkSheet;
      Pos_RightBottom := _HeadLetterOfXls[wkSheetTmp.UsedRange[LCID_Tmp].Columns.Count]+IntToStr(wkSheetTmp.UsedRange[LCID_Tmp].Rows.Count);
      XlsAppTmp.Range[Pos_LeftTop, Pos_RightBottom].Copy(EmptyParam);
      wkSheetRes.Activate(LCID_Res);
      wkSheetRes.Range[Pos_LeftTop, Pos_RightBottom].Select;
      wkSheetRes.Paste(EmptyParam, EmptyParam, LCID_Res);
      wkSheetRes.Columns.AutoFit;
      wkSheetRes.Range['A1','A1'].Select;
      wkSheetRes.Name := StrName+'_'+IntToStr(i);
    end;
  finally
    try
      (wkBookRes.Sheets[1] as _WorkSheet).Activate(LCID_Res);
      wkBookRes.Close(Not(bDontSave) ,Path+'\'+FileName,EmptyParam,LCID_Res);
      XlsAppRes.Quit;
      XlsAppRes.Disconnect;
    finally
      //杀死未关闭的Excel进程
      XlsAppHwnd := FindWindow( Nil,_XlsResCaption );
      if XlsAppHwnd<>0 then SendMessage( XlsAppHwnd, WM_CLOSE, 0, 0);
    end;
    try
      //wkBookTmp.Close(False ,Path+'\'+TmpFlag+IntToStr(i)+FileName,EmptyParam,LCID_Tmp);
      XlsAppTmp.Quit;
      XlsAppTmp.Disconnect;
    finally
      XlsAppHwnd := FindWindow( Nil,_XlsTmpCaption );
      if XlsAppHwnd<>0 then SendMessage( XlsAppHwnd, WM_CLOSE, 0, 0);
        //TerminateProcess(XlsAppHwnd,0);
    end;
    mCompleted := True;
    Screen.Cursor := crDefault;
  end;
end;

procedure DataSetToXLS(ds:TDataSet;fname:String);
var c,r:Integer;
  xls:TXLSWriter;
begin
  xls:=TXLSWriter.create(fname);
  if ds.FieldCount > xls.maxcols then
    xls.maxcols:=ds.fieldcount+1;
  try
    xls.writeBOF;
    xls.WriteDimension;
    for c:=0 to ds.FieldCount-1 do
      xls.Cellstr(0,c,ds.Fields[c].DisplayLabel);
    r:=1;
    ds.first;
    while (not ds.eof) and (r <= xls.maxrows) do begin
      for c:=0 to ds.FieldCount-1 do
        if ds.Fields[c].AsString<>'' then
          xls.WriteField(r,c,ds.Fields[c]);
      inc(r);
      ds.next;
    end;
    xls.writeEOF;
  finally
    xls.free;
  end;
end;

procedure DBGridToXLS(Grid:TDBGrid;fname:String; bSetFieldName:Boolean;CallFunc:TExportXls_CallBackProc;  bAskForStop:Boolean=True);
var c,r,i :Integer;
  xls:TXLSWriter;
  nTotalCount, nCurrentCount : Integer;
  bDontSave:Boolean;
begin
  bDontSave := False;
  Grid.DataSource.DataSet.DisableControls;
  xls:=TXLSWriter.create(fname);
  if Grid.FieldCount > xls.maxcols then
    xls.maxcols:=Grid.fieldcount+1;
  try      
    G_XLSWriterIsRuning := True;
    xls.writeBOF;
    xls.WriteDimension;
    if bSetFieldName then
    begin
      for c:=0 to Grid.FieldCount-1 do
        xls.Cellstr(0,c,Grid.Fields[c].FieldName);
      r :=2;
    end
    else r:=1;
    for c:=0 to Grid.FieldCount-1 do
      xls.Cellstr(r-1,c,Grid.Fields[c].DisplayLabel);
    nTotalCount := Grid.DataSource.DataSet.RecordCount;
    nCurrentCount := 0;
    bDontSave := False;
    Grid.DataSource.DataSet.First;
    for i:=0 to nTotalCount-1 do
    begin
      Application.ProcessMessages;
      if r > xls.maxrows then Raise Exception.Create('导出的数据超过'+IntToStr(xls.maxrows)+'条记录，操作失败！');
      Inc(nCurrentCount);
      CallFunc(nCurrentCount/nTotalCount);
      if G_UserCmd=UserStop then
      begin
        if bAskForStop then
        case Application.MessageBox('您停止了导出数据，请问需要保存吗？(选择“取消”继续导出)','询问',MB_YESNOCANCEL) of
          IDYES: Break;
          IDNO: begin
                  bDontSave := True;
                  Raise Exception.Create('用户停止，导出数据未保存！');
                end;
          IDCANCEL: G_UserCmd := UserDoNothing;
        end
        else begin bDontSave := True; Raise Exception.Create('用户停止，导出数据未保存！'); end;
      end;
      for c:=0 to Grid.FieldCount-1 do
        if (Grid.Fields[c].AsString<>'') then
          xls.WriteField(r,c,Grid.Fields[c]);
      inc(r);
      Grid.DataSource.DataSet.Next;
    end;
  finally
    xls.writeEOF;
    xls.free;
    if bDontSave then DeleteFile(fname);
    Grid.DataSource.DataSet.EnableControls;
    G_XLSWriterIsRuning := False;   
  end;
end;

//将数个XLS合并成一个（分页）
procedure UniteSeveralXLSToOne(const TmpFlag, Path, FileName : String;const iStart, iEnd : Integer);
const
  _HeadLetterOfXls:Array [1..52]of String
            = ('A','B','C','D','E','F','G','H','I','J','K','L','M',
               'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
               'AA','AB','AC','AD','AE','AF','AG','AH','AI','AJ','AK','AL','AM',
               'AN','AO','AP','AQ','AR','AS','AT','AU','AV','AW','AX','AY','AZ');
  _XlsResCaption= 'FKULWJS_SKSLA_892x_RES';
  _XlsTmpCaption= 'FKULWJS_SKSLA_892x_TMP';
var
  XlsAppRes, XlsAppTmp: TExcelApplication;
  wkBookRes, wkBookTmp : _WorkBook;
  wkSheetRes, wkSheetTmp : _WorkSheet;
  LCID_Res, LCID_Tmp:Integer;
  Pos_LeftTop, Pos_RightBottom : String; //Xls中左上、右下位置
  XlsAppHwnd:THandle;
  bDontSave : Boolean;
  i : Integer;

  StrName,StrExt:String; //文件名及扩展名
begin
  SplitStrToTwoPartByLastFlag(FileName, '.', StrName, StrExt);
  try
    bDontSave := False;
    XlsAppRes := TExcelApplication.Create(Nil);
    with XlsAppRes do
    begin
      Connect;
      Visible[0]:=False;
      LCID_Res:=GetUserDefaultLCID();
      DisplayAlerts[LCID_Res]:=False;
      Caption:=_XlsResCaption;
      wkBookRes:=WorkBooks.Add(EmptyParam,LCID_Res);
    end;
    XlsAppTmp := TExcelApplication.Create(Nil);
    with XlsAppTmp do
    begin
      Connect;
      Visible[0]:=False;
      LCID_Tmp :=GetUserDefaultLCID();
      DisplayAlerts[LCID_Tmp]:=False;
      Caption:=_XlsTmpCaption;
    end;
    for i:=iStart to iEnd do
    begin
      if i<=3 then wkSheetRes:=wkBookRes.Sheets[i] as _WorkSheet
      else
      begin
        wkBookRes.Sheets.Add(EmptyParam, wkSheetRes, 1, EmptyParam, LCID_Res);
        wkSheetRes := wkBookRes.Sheets[i] as _WorkSheet;
      end;
      wkBookTmp:= XlsAppTmp.WorkBooks.Open(Path+'\'+TmpFlag+IntToStr(i)+FileName, EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                    EmptyParam,EmptyParam,LCID_Tmp);
      Pos_LeftTop := 'A1';
      wkSheetTmp := XlsAppTmp.ActiveSheet as _WorkSheet;
      Pos_RightBottom := _HeadLetterOfXls[wkSheetTmp.UsedRange[LCID_Tmp].Columns.Count]+IntToStr(wkSheetTmp.UsedRange[LCID_Tmp].Rows.Count);
      XlsAppTmp.Range[Pos_LeftTop, Pos_RightBottom].Copy(EmptyParam);
      wkSheetRes.Activate(LCID_Res);
      wkSheetRes.Range[Pos_LeftTop, Pos_RightBottom].Select;
      wkSheetRes.Paste(EmptyParam, EmptyParam, LCID_Res);
      wkSheetRes.Columns.AutoFit;
      wkSheetRes.Range['A1','A1'].Select;
      wkSheetRes.Name := StrName+'__'+IntToStr(i);
    end;
  finally
    try
      (wkBookRes.Sheets[1] as _WorkSheet).Activate(LCID_Res);
      wkBookRes.Close(Not(bDontSave) ,Path+'\'+FileName,EmptyParam,LCID_Res);
      XlsAppRes.Quit;
      XlsAppRes.Disconnect;
    finally
      //杀死未关闭的Excel进程
      XlsAppHwnd := FindWindow( Nil,_XlsResCaption );
      if XlsAppHwnd<>0 then SendMessage( XlsAppHwnd, WM_CLOSE, 0, 0);
    end;
    try
      //wkBookTmp.Saved[LCID_Tmp]:=True;
      XlsAppTmp.Quit;
      XlsAppTmp.Disconnect;
    finally
      XlsAppHwnd := FindWindow( Nil,_XlsTmpCaption );
      if XlsAppHwnd<>0 then SendMessage( XlsAppHwnd, WM_CLOSE, 0, 0);
    end;
  end;
end;

function DBGridToXlsEx(Grid:TDBGrid;fname:String; bSetFieldName:Boolean;CallFunc:TExportXls_CallBackProc;const bAskForStop:Boolean; const bNeedUnite:Boolean ):Integer;
var
  c,r,i :Integer;
  xls:TXLSWriter;
  nTotalCount, nCurrentCount : Integer;
  bDontSave:Boolean;
  nOneSheetMaxRecord : Integer;
  Path, FileName, tmpFile:String;
  bNotEof : Boolean;
begin
  G_XLSWriterIsRuning := True;
  Result := 0;
  bDontSave := False;
  nTotalCount := Grid.DataSource.DataSet.RecordCount;
  nCurrentCount := 0;
  SplitStrToTwoPartByLastFlag(fname,'\/',Path,FileName);
  Grid.DataSource.DataSet.DisableControls;
  bNotEof := True;
  try
    while bNotEof do
    begin
      Inc(Result);
      tmpFile := Path+'\$$$'+IntToStr(Result)+FileName;
      DeleteFile(tmpFile);
      xls:=TXLSWriter.Create(tmpFile,Grid.FieldCount+1, 65530 );    //65530
      if Grid.FieldCount > xls.maxCols then
        xls.maxCols := Grid.FieldCount+1;
      try
        xls.WriteBOF;
        xls.WriteDimension;
        if bSetFieldName then
        begin
          for c:=0 to Grid.FieldCount-1 do
            xls.Cellstr(0,c,Grid.Fields[c].FieldName);
          r :=2;
        end
        else r:=1;
        for c:=0 to Grid.FieldCount-1 do
          xls.Cellstr(r-1,c,Grid.Fields[c].DisplayLabel);

        Grid.DataSource.DataSet.First;
        Grid.DataSource.DataSet.MoveBy(nCurrentCount);
        if nTotalCount-nCurrentCount>xls.maxrows then nOneSheetMaxRecord := xls.maxRows
        else nOneSheetMaxRecord := nTotalCount-nCurrentCount;
        for i:=0 to nOneSheetMaxRecord-1 do
        begin
          Application.ProcessMessages;
          Inc(nCurrentCount);
          CallFunc(nCurrentCount/nTotalCount);
          if G_UserCmd=UserStop then
          begin
            if bAskForStop then
            case Application.MessageBox('您停止了导出数据，请问需要保存吗？(选择“取消”继续导出)','询问',MB_YESNOCANCEL) of
              IDYES:begin
                      G_UserCmd := UserNeedSave;
                      Break;
                    end;
              IDNO: begin
                      G_UserCmd := UserNotSave;
                      bDontSave := True;
                      Raise Exception.Create('用户停止，导出数据未保存！');
                    end;
              IDCANCEL: G_UserCmd := UserDoNothing;
            end
            else begin bDontSave := True; Raise Exception.Create('用户停止，导出数据未保存！'); end;
          end;
          for c:=0 to Grid.FieldCount-1 do
            if (Grid.Fields[c].AsString<>'') then
              xls.WriteField(r,c,Grid.Fields[c]);
          inc(r);
          Grid.DataSource.DataSet.Next;
        end;
        xls.writeEOF;
      finally
        xls.Free;
      end;
      bNotEof := (Not Grid.DataSource.DataSet.Eof) and (G_UserCmd = UserDoNothing);
    end; //Not Grid.DataSource.DataSet.Eof
  finally
    if bDontSave then
      for i:=1 to Result do DeleteFile(Path+'\$$$'+IntToStr(i)+FileName);
    Grid.DataSource.DataSet.EnableControls;
  end;
  if bNeedUnite and (Not bDontSave) then
  begin
    if Result=1 then
    begin
      DeleteFile(fname);
      RenameFile(tmpFile, fname)
    end
    else
    begin
      with TUniteSeveralXLSToOneThread.Create('$$$', Path, FileName, 1, Result) do
      begin
        while Not mCompleted do
        begin
          Application.ProcessMessages;
          Sleep(0);
        end;
      end;
      for i:=1 to Result do DeleteFile(Path+'\$$$'+IntToStr(i)+FileName);
    end;
  end;
  G_XLSWriterIsRuning := False;
end;
(*
procedure StringGridToXLS(grid:TStringGrid;fname:String);
var c,r,rMax:Integer;
  xls:TXLSWriter;
begin
  xls:=TXLSWriter.create(fname);
  rMax:=grid.RowCount;
  if grid.ColCount > xls.maxcols then
    xls.maxcols:=grid.ColCount+1;
  if rMax > xls.maxrows then          // &brvbar;&sup1;&reg;&aelig;&brvbar;&iexcl;&sup3;&Igrave;&brvbar;h&yen;u&macr;à&brvbar;s 65535 Rows
    rMax:=xls.maxrows;
  try
    xls.writeBOF;
    xls.WriteDimension;
    for c:=0 to grid.ColCount-1 do
      for r:=0 to rMax-1 do
        xls.Cellstr(r,c,grid.Cells[c,r]);
    xls.writeEOF;
  finally
    xls.free;
  end;
end;
*)
{ TXLSWriter }

constructor TXLSWriter.Create(vFileName:string;const vMaxCols, vMaxRows:Integer);
begin
  inherited create;
  if FileExists(vFilename) then
    fStream:=TFileStream.Create(vFilename,fmOpenWrite)
  else
    fStream:=TFileStream.Create(vFilename,fmCreate);
  if vMaxCols<100 then maxCols := vMaxCols   //modify by 角落的青苔@2005/05/19
  else maxCols := 100;
  if vMaxCols<65535 then maxRows := vMaxRows
  else maxRows := 65535;
  //maxCols:=100;   // <2002-11-17> dllee Column &Agrave;&sup3;&cedil;&Oacute;&not;O¤&pound;&yen;i&macr;à¤j&copy;ó 65535, &copy;&Ograve;&yen;H¤&pound;&brvbar;A&sup3;B&sup2;z
  //maxRows:=65530;//65535; // <2002-11-17> dllee &sup3;o&shy;&Oacute;&reg;&aelig;&brvbar;&iexcl;&sup3;&Igrave;¤j&yen;u&macr;à&sup3;o&raquo;ò¤j&iexcl;A&frac12;&ETH;&ordf;`·N¤j&ordf;&ordm;&cedil;ê&reg;&AElig;&reg;w&laquo;&Uuml;&reg;e&copy;&ouml;&acute;N¤j&copy;ó&sup3;o&shy;&Oacute;&shy;&Egrave;
end;

destructor TXLSWriter.Destroy;
begin
  if fStream <> nil then
    fStream.free;
  inherited;
end;

procedure StreamWriteWordArray(Stream: TStream; wr: array of Word);
var
  i: Integer;
begin
  for i := 0 to Length(wr)-1 do
{$IFDEF CIL}
    Stream.Write(wr[i]);
{$ELSE}
    Stream.Write(wr[i], SizeOf(wr[i]));
{$ENDIF}
end;

procedure StreamWriteAnsiString(Stream: TStream; S: String);
{$IFDEF CIL}
var
  b: TBytes;
{$ENDIF}
begin
{$IFDEF CIL}
    b := BytesOf(AnsiString(S));
    Stream.Write(b, Length(b));
{$ELSE}
    Stream.Write(PChar(S)^, Length(S));
{$ENDIF}
end;

procedure TXLSWriter.WriteBOF;
begin
  Writeword(BOF_BIFF5);
  Writeword(6);           // count of bytes
  Writeword(0);
  Writeword(DOCTYPE_XLS);
  Writeword(0);
end;

procedure TXLSWriter.WriteDimension;
begin
  Writeword(DIMENSIONS);  // dimension OP Code
  Writeword(8);           // count of bytes
  Writeword(0);           // min cols
  Writeword(maxRows);     // max rows
  Writeword(0);           // min rowss
  Writeword(maxcols);     // max cols
end;

procedure TXLSWriter.CellDouble(vRow, vCol: word; aValue: double;
  vAtribut: TSetOfAtribut);
//var  FAtribut:array [0..2] of byte;
begin
  CXlsNumber[2] := vRow;
  CXlsNumber[3] := vCol;
  StreamWriteWordArray(fStream, CXlsNumber);
  //SetCellAtribut(vAtribut,fAtribut);
  //fStream.Write(fAtribut,3);
  fStream.WriteBuffer(aValue, 8);
end;

procedure TXLSWriter.CellInteger(vRow,vCol:word;aValue:Integer;vAtribut:TSetOfAtribut=[]);
var V:Integer;
begin
  CXlsRk[2] := vRow;
  CXlsRk[3] := vCol;
  StreamWriteWordArray(fStream, CXlsRk);
  V := (aValue shl 2) or 2;
  fStream.WriteBuffer(V, 4);
end;

procedure TXLSWriter.CellStr(vRow, vCol: word; aValue: String;
  vAtribut: TSetOfAtribut);
var slen:Word;
begin
  slen := Length(aValue);
  CXlsLabel[1] := 8 + slen;
  CXlsLabel[2] := vRow;
  CXlsLabel[3] := vCol;
  //SetCellAtribut(vAtribut, CXlsLabel[4]);
  CXlsLabel[5] := slen;
  StreamWriteWordArray(fStream, CXlsLabel);
  StreamWriteAnsiString(fStream, aValue);
end;

procedure TXLSWriter.SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte);
var
   i:integer;
begin
 //reset
  for i:=0 to High(FAtribut) do
    FAtribut[i]:=0;

     if  acHidden in value then       //byte 0 bit 7:
         FAtribut[0] := FAtribut[0] + 128;

     if  acLocked in value then       //byte 0 bit 6:
         FAtribut[0] := FAtribut[0] + 64 ;

     if  acShaded in value then       //byte 2 bit 7:
         FAtribut[2] := FAtribut[2] + 128;

     if  acBottomBorder in value then //byte 2 bit 6
         FAtribut[2] := FAtribut[2] + 64 ;

     if  acTopBorder in value then    //byte 2 bit 5
         FAtribut[2] := FAtribut[2] + 32;

     if  acRightBorder in value then  //byte 2 bit 4
         FAtribut[2] := FAtribut[2] + 16;

     if  acLeftBorder in value then   //byte 2 bit 3
         FAtribut[2] := FAtribut[2] + 8;

     // <2002-11-17> dllee &sup3;&Igrave;&laquo;á 3 bit &Agrave;&sup3;&yen;u&brvbar;&sup3; 1 &ordm;&Oslash;&iquest;&iuml;&frac34;&Uuml;
     if  acLeft in value then         //byte 2 bit 1
         FAtribut[2] := FAtribut[2] + 1
     else if  acCenter in value then  //byte 2 bit 1
         FAtribut[2] := FAtribut[2] + 2
     else if acRight in value then    //byte 2, bit 0 dan bit 1
         FAtribut[2] := FAtribut[2] + 3
     else if acFill in value then     //byte 2, bit 0
         FAtribut[2] := FAtribut[2] + 4;
end;

procedure TXLSWriter.WriteWord(w: word);
begin
  fstream.Write(w,2);
end;

procedure TXLSWriter.WriteEOF;
begin
  Writeword(BIFF_EOF);
  Writeword(0);
end;

procedure TXLSWriter.WriteField(vRow, vCol: word; Field: TField);
begin
  case field.DataType of
     ftString,ftWideString,ftBoolean,ftDate,ftDateTime,ftTime:
       Cellstr(vRow,vCol,field.asstring);
     ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
       CellInteger(vRow,vCol,field.AsInteger);
     ftFloat, ftBCD:
       CellDouble(vRow,vCol,field.AsFloat);
  else
       Cellstr(vRow,vCol,EmptyStr);   // <2002-11-17> dllee ¨&auml;&yen;L&laquo;&not;&ordm;A&frac14;g¤J&ordf;&Aring;&yen;&Otilde;&brvbar;r&brvbar;ê
  end;
end;

initialization
  G_XLSWriterIsRuning := False;
 
end.

相关软件：