请问谁有将DBGRID中的内容输出到EXCEL中的代码？(50分)

我想将在DBgrid中的查询信息输出到Excel中保存和打印，不知哪位朋友有源代码？

unit UExecl;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
comobj, DBTables, Grids;
type
TOLEExcel = class(TComponent)
private
FExcelCreated: Boolean;
FVisible: Boolean;
FExcel: Variant;
FWorkBook: Variant;
FWorkSheet: Variant;
FCellFont: TFont;
FTitleFont: TFont;
FFontChanged: Boolean;
FIgnoreFont: Boolean;
FFileName :TFileName;//add by David
procedure SetExcelCellFont( var Cell: Variant );
procedure SetExcelTitleFont( var Cell: Variant );
procedure GetTableColumnName( const Table: TTable;
var Cell: Variant );
procedure GetQueryColumnName( const Query: TQuery;
var Cell: Variant );
procedure GetFixedCols( const StringGrid: TStringGrid;
var Cell: Variant );
procedure GetFixedRows( const StringGrid: TStringGrid;
var Cell: Variant );
procedure GetStringGridBody( const StringGrid: TStringGrid;
var Cell: Variant );
protected
procedure SetCellFont( NewFont: TFont );
procedure SetTitleFont( NewFont: TFont );
procedure SetVisible(DoShow: Boolean);
function GetCell(ACol, ARow: Integer): string;
procedure SetCell(ACol, ARow: Integer;
const Value: string);
function GetDateCell(ACol, ARow: Integer): TDateTime;
procedure SetDateCell(ACol, ARow: Integer;
const Value: TDateTime);
public
constructor Create ( AOwner : TComponent );
override;
destructor Destroy;
override;
procedure CreateExcelInstance;
property Cell[ACol, ARow: Integer]: string read GetCell write SetCell;
property DateCell[ACol, ARow: Integer]: TDateTime read GetDateCell write SetDateCell;
function IsCreated: Boolean;
procedure TableToExcel( const Table: TTable );
procedure QueryToExcel( const Query: TQuery );
procedure StringGridToExcel( const StringGrid: TStringGrid );
published
property TitleFont: TFont read FTitleFont write SetTitleFont;
property CellFont: TFont read FCellFont write SetCellFont;
property Visible: Boolean read FVisible write SetVisible;
property IgnoreFont: Boolean read FIgnoreFont write FIgnoreFont;
property FileName:TFileName read FFileName write FFileName;
end;

procedure Register;
implementation
constructor TOLEExcel.Create ( AOwner : TComponent );
begin
inherited Create( AOwner );
FIgnoreFont := True;
FCellFont := TFont.Create;
FTitleFont := TFont.Create;
FExcelCreated := False;
FVisible := False;
FFontChanged := False;
end;

destructor TOLEExcel.Destroy;
begin
FCellFont.Free;
FTitleFont.Free;
inherited Destroy;
end;

procedure TOLEExcel.SetExcelCellFont( var Cell: Variant );
begin
if FIgnoreFont then
exit;
with FCellFontdo
begin
Cell.Font.Name := Name;
Cell.Font.Size := Size;
Cell.Font.Color := Color;
Cell.Font.Bold := fsBold in Style;
Cell.Font.Italic := fsItalic in Style;
Cell.Font.UnderLine := fsUnderline in Style;
Cell.Font.Strikethrough := fsStrikeout in Style;
end;
end;

procedure TOLEExcel.SetExcelTitleFont( var Cell: Variant );
begin
if FIgnoreFont then
exit;
with FTitleFontdo
begin
Cell.Font.Name := Name;
Cell.Font.Size := Size;
Cell.Font.Color := Color;
Cell.Font.Bold := fsBold in Style;
Cell.Font.Italic := fsItalic in Style;
Cell.Font.UnderLine := fsUnderline in Style;
Cell.Font.Strikethrough := fsStrikeout in Style;
end;
end;

procedure TOLEExcel.SetVisible(do
Show: Boolean );
begin
if not FExcelCreated then
exit;
ifdo
Show then
FExcel.Visible := True
else
FExcel.Visible := False;
end;

function TOLEExcel.GetCell( ACol, ARow: Integer ): string;
begin
if not FExcelCreated then
exit;
result := FWorkSheet.Cells[ ARow, ACol ];
end;

procedure TOLEExcel.SetCell(ACol, ARow: Integer;
const Value: string);
var
Cell: Variant;
begin
if not FExcelCreated then
exit;
Cell := FWorkSheet.Cells[ ARow, ACol ];
SetExcelCellFont( Cell );
Cell.Value := Value;
end;

function TOLEExcel.GetDateCell( ACol, ARow: Integer ): TDateTime;
begin
if not FExcelCreated then
begin
result := 0;
exit;
end;
result := StrToDateTime( FWorkSheet.Cells[ ARow, ACol ] );
end;

procedure TOLEExcel.SetDateCell(ACol, ARow: Integer;
const Value: TDateTime);
var
Cell: Variant;
begin
if not FExcelCreated then
exit;
Cell := FWorkSheet.Cells[ ARow, ACol ];
SetExcelCellFont( Cell );
Cell.Value := '''' + DateTimeToStr( Value );
end;

procedure TOLEExcel.CreateExcelInstance;
begin
try
FExcel := CreateOLEObject( 'Excel.Application' );
FWorkBook := FExcel.WorkBooks.Add;
FWorkSheet:=FWorkBook.WorkSheets.Add;
FExcelCreated:= True;
except
FExcelCreated := False;
end;
end;

function TOLEExcel.IsCreated: Boolean;
begin
result := FExcelCreated;
end;

procedure TOLEExcel.SetTitleFont( NewFont: TFont );
begin
if NewFont <> FTitleFont then
FTitleFont.Assign( NewFont );
end;

procedure TOLEExcel.SetCellFont( NewFont: TFont );
begin
if NewFont <> FCellFont then
FCellFont.Assign( NewFont );
end;

procedure TOLEExcel.GetTableColumnName( const Table: TTable;
var Cell: Variant );
var
Col: integer;
begin
for Col := 0 to Table.FieldCount-1do
begin
Cell := FWorkSheet.Cells[ 1, Col+1 ];
SetExcelTitleFont( Cell );
Cell.Value := Table.Fields[ Col ].FieldName;
end;
end;

procedure TOLEExcel.TableToExcel( const Table: TTable );
var
Col, Row: LongInt;
Cell: Variant;
begin
if not FExcelCreated then
exit;
if Table.Active = False then
exit;
GetTableColumnName( Table, Cell );
Row := 2;
with Tabledo
begin
first;
while not EOFdo
begin
for Col := 0 to FieldCount-1do
begin
Cell := FWorkSheet.Cells[ Row, Col+1 ];
SetExcelCellFont( Cell );
Cell.Value := Fields[ Col ].AsString;
end;
next;
Inc( Row );
end;
end;
end;

procedure TOLEExcel.GetQueryColumnName( const Query: TQuery;
var Cell: Variant );
var
Col: integer;
begin
for Col := 0 to Query.FieldCount-1do
begin
Cell := FWorkSheet.Cells[ 1, Col+1 ];
SetExcelTitleFont( Cell );
Cell.Value := Query.Fields[ Col ].DisplayName ;
end;
end;

procedure TOLEExcel.QueryToExcel( const Query: TQuery );
var
Col, Row: LongInt;
Cell: Variant;
begin
if not FExcelCreated then
exit;
if Query.Active = False then
exit;
GetQueryColumnName( Query, Cell );
Row := 2;
with Querydo
begin
first;
while not EOFdo
begin
for Col := 0 to FieldCount-1do
begin
Cell := FWorkSheet.Cells[ Row, Col+1 ];
SetExcelCellFont( Cell );
Cell.Value := '‘'+Fields[ Col ].AsString;
end;
next;
Inc( Row );
end;
end;
end;

procedure TOLEExcel.GetFixedCols( const StringGrid: TStringGrid;
var Cell: Variant );
var
Col, Row: LongInt;
begin
for Col := 0 to StringGrid.FixedCols-1do
for Row := 0 to StringGrid.RowCount-1do
begin
Cell := FWorkSheet.Cells[ Row+1, Col+1 ];
SetExcelTitleFont( Cell );
Cell.Value := StringGrid.Cells[ Col, Row ];
end;
end;

procedure TOLEExcel.GetFixedRows( const StringGrid: TStringGrid;
var Cell: Variant );
var
Col, Row: LongInt;
begin
for Row := 0 to StringGrid.FixedRows-1do
for Col := 0 to StringGrid.ColCount-1do
begin
Cell := FWorkSheet.Cells[ Row+1, Col+1 ];
SetExcelTitleFont( Cell );
Cell.Value := StringGrid.Cells[ Col, Row ];
end;
end;

procedure TOLEExcel.GetStringGridBody( const StringGrid: TStringGrid;
var Cell: Variant );
var
Col, Row, x, y: LongInt;
begin
Col := StringGrid.FixedCols;
Row := StringGrid.FixedRows;
for x := Row to StringGrid.RowCount-1do
for y := Col to StringGrid.ColCount-1do
begin
Cell := FWorkSheet.Cells[ x+1, y+1 ];
SetExcelCellFont( Cell );
Cell.Value := StringGrid.Cells[ y, x ];
end;
end;

procedure TOLEExcel.StringGridToExcel( const StringGrid: TStringGrid );
var
Cell: Variant;
begin
if not FExcelCreated then
exit;
GetFixedCols( StringGrid, Cell );
GetFixedRows( StringGrid, Cell );
GetStringGridBody( StringGrid, Cell );
end;

procedure Register;
begin
RegisterComponents('Arm007', [TOLEExcel]);
end;

end.

以下代码包含StringGrid和DBGrid输出到Execl的功能，
输出到execl后你就可以用execl打印了。
procedure TForm_Main.SaveToExecl(Sender: TObject);
var
Gridbm: TBookmark;
x_num, y_num,loopint :Integer;
TempFile,ExeclLine :String;
MSExcel :OleVariant;
ExeclList :TStringList;//用于存储数据的字符列表
StatField :string;
begin
if((ActiveControl is TDBGrid ) = false)
and((ActiveControl is TStringGrid) = false) then
exit;
StatField := StrNull;
tempfile := extractfilepath(application.exename)+'TGSTemp.xls';
try //删除动态生成的临时temp.xls文件
if FileExists(tempfile) then
DeleteFile(tempfile);
except
message_show('建立临时文档'+tempfile+'失败！');
exit;
end;
ExeclList := TStringList.Create;
Gridbm := nil;
{}
try
if(ActiveControl is TDBGrid) then
with TDBGrid(ActiveControl)do
begin
Gridbm := DataSource.DataSet.GetBookmark;
{定义Execl列标题}
for x_num:=0 to FieldCount-1do
begin
if(Columns[x_num].Visible = false) then
continue;
ExeclLine := ExeclLine +Columns[x_num].Title.Caption +#9;
end;
ExeclList.Add(ExeclLine);
{转换数据到Excel}
DataSource.DataSet.DisableControls;
DataSource.DataSet.First;
for y_num:=0 to DataSource.DataSet.RecordCount-1do
begin
// if(SelectedRows.Count > 1) and(SelectedRows.CurrentRowSelected = false) then
continue;{无效}
ExeclLine:='';
loopint :=0;
for x_num:=0 to FieldCount-1do
begin
if(Columns[x_num].Visible = false) then
continue;
try
ExeclLine := ExeclLine +Fields[x_num].AsString +#9;
except
ExeclLine := ExeclLine +strNull +#9;
end;
end;
ExeclList.Add(ExeclLine);
DataSource.DataSet.Next;
end;
end else
if(ActiveControl is TStringGrid) then
with TStringGrid(ActiveControl)do
begin
for y_num:=0 to RowCount-1do
begin
if(RowHeights[y_num] <= 0) then
continue;
ExeclLine := '';
for x_num := 0 to ColCount-1do
begin
if(ColWidths[x_num] <= 0) then
continue;
ExeclLine := ExeclLine +Cells[x_num,y_num] +#9;
end;
ExeclList.Add(ExeclLine);
end;
end;
ExeclList.SaveToFile(tempfile);//存储路径
try
MSExcel := CreateOleObject('Excel.Application');{建立Execl对象}
MSExcel.WorkBooks.Open(tempfile);
MSExcel.Visible := True;
except
ShowMessage('本机没有安装Microsoft Excel,'#$D'打开文档失败！');
end;
finally
ExeclList.Free;
if(Gridbm <> nil) then
with TDBGrid(ActiveControl)do
begin
DataSource.DataSet.EnableControls;
DataSource.DataSet.GotoBookmark(Gridbm);
DataSource.DataSet.FreeBookmark(Gridbm);
TStringGrid(ActiveControl).FixedCols := TDBGrid(ActiveControl).HelpContext;
end;
if(MSExcel.Visible = false) then
begin
MSExcel.Saved := True;
//不保存Execl文档
MSExcel.Quit;
//退出Execl程序
MSExcel := Unassigned;
//释放VARIANT变量 ?
showmessage('输出失败');
end;
end;
end;

如果只是为了打印,输出到Excel不如输出到Word...