//На вход передаешь имя DBGrid'a и вперед...

uses ComObj, Gauges, Excel2000, Variants;

procedure TForm1.ToExcel2(gr : TDBGrid);
var
XL : Variant;
SH, CR : Variant;
i, j, k : Integer;
bm : TBookMark;
TF: TForm;
TG : TGauge;
begin
TF := TForm.Create(Self);
TG:=TGauge.Create(TF);
TG.Parent := TF;
TG.Align:=alClient;
TF.Height:=50;
TF.BorderIcons:=[];
TF.Position:=poScreenCenter;
TF.FormStyle:=fsStayOnTop;
TF.Caption:='Экспорт в Excel...';
TG.ForeColor:=clBlue;
TF.Show;
Application.ProcessMessages;
try
Screen.Cursor:=crHourglass;
gr.DataSource.DataSet.DisableControls;
gr.DataSource.DataSet.First;
k:=0;
while not gr.DataSource.DataSet.EOF do
begin
k:=k+1;
gr.DataSource.DataSet.Next;
end;
XL:=CreateOLEObject('Excel.Application');
XL.WorkBooks.Add(-4167);
XL.WorkBooks.WorkSheets.Name:='Экспорт';
SH:=XL.WorkBooks.WorkSheets['Экспорт'];
CR:=XL.WorkBooks.WorkSheets['Экспорт'].Columns;
bm:=gr.DataSource.DataSet.GetBookmark;
for i:=0 to gr.Columns.Count-1 do
begin
CR.Columns[i+1].Name:=gr.Columns .Field.Name;
CR.Columns[i+1].ColumnWidth:=gr.Columns.Width/7.38;
CR.Columns[i+1].Font.Name:=gr.Columns.Font.Name;
CR.Columns[i+1].Font.Size:=gr.Columns.Font.Size;
SH.Cells[1,i+1]:=gr.Columns.Title.Caption;
SH.Cells[1,i+1].Interior.ColorIndex:=12;
SH.Cells[1,i+1].Borders.LineStyle:=xlContinuous;
end;
gr.DataSource.DataSet.First;
TG.MaxValue:=k;
i:=2;
while not gr.DataSource.DataSet.EOF do
begin
TG.Progress:=i-1;
TG.Refresh;
for j:=0 to gr.Columns.Count-1 do
begin
case gr.Columns[j].Field.DataType of
ftString, ftWideString : SH.Cells[i,j+1] :=chr(39)+gr.Columns[j].Field.Text;
ftFloat, ftCurrency, ftSmallint, ftInteger, ftWord,ftBCD :
begin
if Trim(gr.Columns[j].Field.Text)='' then SH.Cells[i,j+1] :=''
else SH.Cells[i,j+1] :=FormatFloat('0.0000',gr.Columns[j].Field.Value);
end;
else
SH.Cells[i,j+1]:=gr.Columns[j].Field.Value;
end;
end;
gr.DataSource.DataSet.Next;
i:=i+1;
end;
finally
XL.Visible:=True;
TF.Release;
gr.DataSource.DataSet.GotoBookmark(bm);
gr.DataSource.DataSet.FreeBookmark(bm);
gr.DataSource.DataSet.EnableControls;
Screen.Cursor:=crDefault;
end;
end;