Delphi

本类阅读TOP10

·分布式网络考试系统原型分析及实现
·游戏外挂设计技术探讨①
·使用HOOK随心监视Windows
·Delphi 水晶报表打包解决
·试题库开发中非文本数据的处理
·如何将几个DBGRID里的内容导入同一个EXCEL表中....的问题
·如何使用Delphi设计强大的服务器程序
·工人线程中关闭窗体的实现
·用DLL方式封装MDI子窗体。
·支持XP下托盘栏气球提示的托盘单元

分类导航
VC语言Delphi
VB语言ASP
PerlJava
Script数据库
其他语言游戏开发
文件格式网站制作
软件工程.NET开发
修改的一个导出DataSet到xls的单元

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

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

(* Modify By 角落的青[email protected]/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 角落的青[email protected]/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 角落的青[email protected]/05/13 //只能导出最多65536条记录
procedure DBGridToXLS(Grid:TDBGrid;fname:String; bSetFieldName:Boolean;CallFunc:TExportXls_CallBackProc; bAskForStop:Boolean=True );
//Add By 角落的青[email protected]/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 角落的青[email protected]/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.




相关文章

相关软件




月光软件源码下载编程文档电脑教程网站优化网址导航网络文学游戏天地生活休闲写作范文安妮宝贝站内搜索
电脑技术编程开发网络专区谈天说地情感世界游戏元素分类游戏热门游戏体育运动手机专区业余爱好影视沙龙
音乐天地数码广场教育园地科学大观古今纵横谈股论金人文艺术医学保健动漫图酷二手专区地方风情各行各业

月光软件站·版权所有