• 修改的一个导出DataSet到xls的单元


    (*首先感谢原作者,但当初在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.

  • 相关阅读:
    DataTable用中使用Compute 实现简单的DataTable数据的统计
    绑定生成一个有树结构的下拉菜单
    Docker--UI管理-----------Portainer安装部署使用
    调整系统的inode数量
    配置Linux服务器从第三方 SMTP 服务器外发邮件
    Jenkins的用户角色权限管理
    shell脚本----MongoDB4.0.21一键安装
    Shell----监控CPU/内存/负载高时的进程
    MySQL配置参数优化
    shell脚本实现---Zabbix5.0快速部署
  • 原文地址:https://www.cnblogs.com/hnxxcxg/p/2940774.html
Copyright © 2020-2023  润新知