unit dcexcel;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
  Dialogs, DB, ADODB,  Mask, SHELLAPI;

var
  arXlsBegin: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
  arXlsEnd: array[0..1] of Word = ($0A, 00);
  arXlsString: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  arXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
  arXlsInteger: array[0..4] of Word = ($27E, 10, 0, 0, 0);
  arXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);
  SaveDialog1: TSaveDialog;
  FileName: string;
  Procedure ExportExcelFile( aDataSet: TDataSet);

implementation


Procedure ExportExcelFile( aDataSet: TDataSet);
var
  i,j: integer;
  Col,row: word;
  ABookMark: TBookMark;
  aFileStream: TFileStream;
  bWriteTitle: Boolean;
procedure incColRow; //增加行列號
begin
  if Col = ADataSet.FieldCount - 1 then
  begin
    Inc(Row);
    Col :=0;
  end
  else
    Inc(Col);
  end;
procedure WriteStringCell(AValue: string);//寫字符串數據
var
  L: Word;
begin
  L := Length(AValue);
  arXlsString[1] := 8 + L;
  arXlsString[2]:=Row;
  arXlsString[3] := Col;
  arXlsString[5] := L;
  aFileStream.WriteBuffer(arXlsString, SizeOf(arXlsString));
  aFileStream.WriteBuffer(Pointer(AValue)^, L);
  IncColRow;
end;
procedure WriteIntegerCell(AValue: integer);//寫整數
var
  V: Integer;
begin
  arXlsInteger[2] := Row;
  arXlsInteger[3] := Col;
  aFileStream.WriteBuffer(arXlsInteger, SizeOf(arXlsInteger));
  V := (AValue shl 2) or 2;
  aFileStream.WriteBuffer(V, 4);
  IncColRow;
end;

procedure WriteFloatCell(AValue: double);//寫浮點數
begin
  arXlsNumber[2] := Row;
  arXlsNumber[3] := Col;
  aFileStream.WriteBuffer(arXlsNumber, SizeOf(arXlsNumber));
  aFileStream.WriteBuffer(AValue, 8);
  IncColRow;
end;
begin
  bWriteTitle:=true;
  SaveDialog1:= TSaveDialog.Create(nil);
  savedialog1.DefaultExt:='*.xls';
  savedialog1.Filter:='EXCEL文件(*.xls)|*.xls';
  if savedialog1.Execute then
    begin
      FileName:=savedialog1.FileName;
    end
    else
    begin
      //showmessage('請指定文件名！');
      exit;
    end;
  if FileExists(FileName) then DeleteFile(FileName); //文件存在，先刪除
  aFileStream := TFileStream.Create(FileName, fmCreate);
Try
  //寫文件頭
  aFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin));
  //寫列頭
  Col := 0; Row := 0;
  if bWriteTitle then
  begin
  for i := 0 to aDataSet.FieldCount - 1 do
  WriteStringCell(aDataSet.Fields[i].FieldName);
  end;
  //寫數據集中的數據
  aDataSet.DisableControls;
  ABookMark := aDataSet.GetBookmark;
  aDataSet.First;
  while not aDataSet.Eof do
  begin
  for i := 0 to aDataSet.FieldCount - 1 do
  case ADataSet.Fields[i].DataType of
  ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
  WriteIntegerCell(aDataSet.Fields[i].AsInteger);
  ftFloat, ftCurrency, ftBCD:
  WriteFloatCell(aDataSet.Fields[i].AsFloat)
  else
  WriteStringCell(aDataSet.Fields[i].AsString);
  end;
  aDataSet.Next;
  end;
  //寫文件尾
  AFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
  if ADataSet.BookmarkValid(ABookMark) then aDataSet.GotoBookmark(ABookMark);
Finally
  AFileStream.Free;
  ADataSet.EnableControls;
  savedialog1.Free;
end;
showmessage('   導出成功！  ');
end;



end.