unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,db, StdCtrls, ADODB,excel2000,comobj;
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
TForm1 = class(TForm)
Button1: TButton;
ADOQuery1: TADOQuery;
SaveDialog1: TSaveDialog;

procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Type
TDS2Excel = Class(TObject)
Private
FCol: word;
FRow: word;
FDataSet: TDataSet;
Stream: TStream;
FWillWriteHead: boolean;
FBookMark: TBookmark;
procedure IncColRow;
procedure WriteBlankCell;
procedure WriteFloatCell(const AValue: Double);
procedure WriteIntegerCell(const AValue: Integer);
procedure WriteStringCell(const AValue: string);
procedure WritePrefix;
procedure WriteSuffix;
procedure WriteTitle;
procedure WriteDataCell;

procedure Save2Stream(aStream: TStream);
Public
procedure Save2File(FileName: string; WillWriteHead: Boolean);
Constructor Create(aDataSet: TDataSet);
end;

var
Form1: TForm1;

implementation
var
filename:string;

{$R *.dfm}

Constructor TDS2Excel.Create(aDataSet: TDataSet);
begin
inherited Create;
FDataSet := aDataSet;
end;

procedure TDS2Excel.IncColRow;
begin
if FCol = FDataSet.FieldCount - 1 then
begin
Inc(FRow);
FCol :=0;
end
else
Inc(FCol);
end;

procedure TDS2Excel.WriteBlankCell;
begin
CXlsBlank[2] := FRow;
CXlsBlank[3] := FCol;
Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
IncColRow;
end;

procedure TDS2Excel.WriteFloatCell(const AValue: Double);
begin
CXlsNumber[2]:= FRow;
CXlsNumber[3] := FCol;
Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
Stream.WriteBuffer(AValue, 8);
IncColRow;
end;

procedure TDS2Excel.WriteIntegerCell(const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := FRow;
CXlsRk[3] := FCol;
Stream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
Stream.WriteBuffer(V, 4);
IncColRow;
end;

procedure TDS2Excel.WriteStringCell(const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := FRow;
CXlsLabel[3] := FCol;
CXlsLabel[4] := 8;
CXlsLabel[5] := L;
Stream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
Stream.WriteBuffer(Pointer(AValue)^, L);
IncColRow;
end;

procedure TDS2Excel.WritePrefix;
begin
Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure TDS2Excel.WriteSuffix;
begin
Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure TDS2Excel.WriteTitle;
var
n: word;
begin
for n := 0 to FDataSet.FieldCount - 1 do
WriteStringCell(FDataSet.Fields[n].FieldName);

end;

procedure TDS2Excel.WriteDataCell;
var
n: word;
begin
WritePrefix;
if FWillWriteHead then WriteTitle;
FDataSet.DisableControls;
FBookMark := FDataSet.GetBookmark;
FDataSet.First;
while not FDataSet.Eof do
begin
for n := 0 to FDataSet.FieldCount - 1 do
begin
if FDataSet.Fields[n].IsNull then
WriteBlankCell
else begin
case FDataSet.Fields[n].DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
WriteIntegerCell(FDataSet.Fields[n].AsInteger);
ftFloat, ftCurrency, ftBCD:
WriteFloatCell(FDataSet.Fields[n].AsFloat);
else
WriteStringCell(FDataSet.Fields[n].AsString);
end;
end;
end;
FDataSet.Next;
end;
WriteSuffix;
if FDataSet.BookmarkValid(FBookMark) then FDataSet.GotoBookmark(FBookMark);
FDataSet.EnableControls;
end;

procedure TDS2Excel.Save2Stream(aStream: TStream);
begin
FCol := 0;
FRow := 0;
Stream := aStream;
WriteDataCell;
end;

procedure TDS2Excel.Save2File(FileName: string; WillWriteHead: Boolean);
var
aFileStream: TFileStream;
begin
FWillWriteHead := WillWriteHead;
if FileExists(FileName) then DeleteFile(FileName);
aFileStream := TFileStream.Create(FileName, fmCreate);
Try
Save2Stream(aFileStream);
Finally
aFileStream.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
ExcelApplication1:tExcelApplication;
a:exceLrange;
i:integer;
excel,sheet:variant;
begin
if savedialog1.execute then
filename:=savedialog1.filename;
with TDS2Excel.Create(Adoquery1) do
Try
Save2File(filename, true);
finally
Free;
end;
{ excel:=createoleObject('Excel.Application');
sheet:= createoleObject('Excel.sheet');
excel.workbooks.open(filename);
sheet:= excel.worksheets[1];
excel.visible:=true; }

ExcelApplication1:=TExcelApplication.create(nil);
ExcelApplication1.Workbooks.Add(Filename, 0);
ExcelApplication1.connect;
ExcelApplication1.visible[0]:=false;
for i:=1 to ADOQuery1.RecordCount do
begin
a:=excel.activesheet.Range['J'+inttostr(i)+':'+'K'+inttostr(i)];
a.merge(1);
end;
// ExcelApplication1.Disconnect;
// excel.activesheet.rows[10].pagebreak:=1;
ExcelApplication1.Worksheets[1].rows[10].pagebreak:=1;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
savedialog1.filter:='Excel files(*.xls)|*.xls';
savedialog1.DefaultExt:=string('xls');
end;

end.
以文件流的形式导出的 速度超快


简单的
procedure DataToExcel(dataset:TcustomADODataset);
var
Excel:variant;
i,j:integer;
begin
try
Excel:=createOleobject('excel.application');
except
application.MessageBox('please install MicrOSoft Excel First ！','information',mb_ok+mb_iconinformation);
exit;
end;
Excel.workbooks.add;
with dataset do
begin
disablecontrols;
i:=1;
for i:=1 to FieldCount do
begin
excel.cells[1,i].value:=Fields[i-1].FieldName;
end;
i:=2;
first;
while not eof do
begin
for j:=1 to fieldcount do
begin
excel.cells[i,j].value:=Fields[j-1].value;
end;
next;
i:=i+1;
end;
enablecontrols;
end;

excel.visible:=true;
end;

[此贴子已经被作者于2006-8-29 13:07:51编辑过]