Как экспортировать данные из StringGrid в Excel?

{1. With OLE Automation }

uses
  ComObj;
 
function RefToCell(ARow, ACol: Integer): string;
begin
  Result := Chr(Ord('A') + ACol - 1) + IntToStr(ARow);
end;
 
function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean;
const
  xlWBATWorksheet = -4167;
var
  Row, Col: Integer;
  GridPrevFile: string;
  XLApp, Sheet, Data: OLEVariant;
  i, j: Integer;
begin
  // Prepare Data
  Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount], varVariant);
  for i := 0 to AGrid.ColCount - 1 do
    for j := 0 to AGrid.RowCount - 1 do
      Data[j + 1, i + 1] := AGrid.Cells[i, j];
  // Create Excel-OLE Object
  Result := False;
  XLApp := CreateOleObject('Excel.Application');
  try
    // Hide Excel
    XLApp.Visible := False;
    // Add new Workbook
    XLApp.Workbooks.Add(xlWBatWorkSheet);
    Sheet := XLApp.Workbooks[1].WorkSheets[1];
    Sheet.Name := ASheetName;
    // Fill up the sheet
    Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount,
      AGrid.ColCount)].Value := Data;
    // Save Excel Worksheet
    try
      XLApp.Workbooks[1].SaveAs(AFileName);
      Result := True;
    except
      // Error ?
    end;
  finally
    // Quit Excel
    if not VarIsEmpty(XLApp) then
    begin
      XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
    end;
  end;
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SaveAsExcelFile(stringGrid1, 'My Stringgrid Data', 'c:\MyExcelFile.xls') then
    ShowMessage('StringGrid saved!');
end;

{**************************************************************}

{2. Without OLE }

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: string);
var
  L: Word;
const
  {$J+}
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  {$J-}
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := ARow;
  CXlsLabel[3] := ACol;
  CXlsLabel[5] := L;
  XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;
 
 
function SaveAsExcelFile(AGrid: TStringGrid; AFileName: string): Boolean;
const
  {$J+} CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0); {$J-}
  CXlsEof: array[0..1] of Word = ($0A, 00);
var
  FStream: TFileStream;
  I, J: Integer;
begin
  Result := False;
  FStream := TFileStream.Create(PChar(AFileName), fmCreate or fmOpenWrite);
  try
    CXlsBof[4] := 0;
    FStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
    for i := 0 to AGrid.ColCount - 1 do
      for j := 0 to AGrid.RowCount - 1 do
        XlsWriteCellLabel(FStream, I, J, AGrid.cells[i, j]);
    FStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
    Result := True;
  finally
    FStream.Free;
  end;
end;

// Example:

procedure TForm1.Button2Click(Sender: TObject);
begin
  if SaveAsExcelFile(StringGrid1, 'c:\MyExcelFile.xls') then
    ShowMessage('StringGrid saved!');
end;

{**************************************************************}

{3. Code by Reinhard Schatzl }

uses
  ComObj;
 
// Hilfsfunktion fur StringGridToExcelSheet
// Helper function for StringGridToExcelSheet
function RefToCell(RowID, ColID: Integer): string;
var
  ACount, APos: Integer;
begin
  ACount := ColID div 26;
  APos := ColID mod 26;
  if APos = 0 then
  begin
    ACount := ACount - 1;
    APos := 26;
  end;
 
  if ACount = 0 then
    Result := Chr(Ord('A') + ColID - 1) + IntToStr(RowID);
 
  if ACount = 1 then
    Result := 'A' + Chr(Ord('A') + APos - 1) + IntToStr(RowID);
 
  if ACount > 1 then
    Result := Chr(Ord('A') + ACount - 1) + Chr(Ord('A') + APos - 1) + IntToStr(RowID);
end;
 
// StringGrid Inhalt in Excel exportieren
// Export StringGrid contents to Excel
function StringGridToExcelSheet(Grid: TStringGrid; SheetName, FileName: string;
  ShowExcel: Boolean): Boolean;
const
  xlWBATWorksheet = -4167;
var
  SheetCount, SheetColCount, SheetRowCount, BookCount: Integer;
  XLApp, Sheet, Data: OLEVariant;
  I, J, N, M: Integer;
  SaveFileName: string;
begin
  //notwendige Sheetanzahl feststellen
  SheetCount := (Grid.ColCount div 256) + 1;
  if Grid.ColCount mod 256 = 0 then
    SheetCount := SheetCount - 1;
  //notwendige Bookanzahl feststellen
  BookCount := (Grid.RowCount div 65536) + 1;
  if Grid.RowCount mod 65536 = 0 then
    BookCount := BookCount - 1;
 
  //Create Excel-OLE Object
  Result := False;
  XLApp  := CreateOleObject('Excel.Application');
  try
    //Excelsheet anzeigen
    if ShowExcel = False then
      XLApp.Visible := False
    else
      XLApp.Visible := True;
    //Workbook hinzufugen
    for M := 1 to BookCount do
    begin
      XLApp.Workbooks.Add(xlWBATWorksheet);
      //Sheets anlegen
      for N := 1 to SheetCount - 1 do
      begin
        XLApp.Worksheets.Add;
      end;
    end;
    //Sheet ColAnzahl feststellen
    if Grid.ColCount <= 256 then
      SheetColCount := Grid.ColCount
    else
      SheetColCount := 256;
    //Sheet RowAnzahl feststellen
    if Grid.RowCount <= 65536 then
      SheetRowCount := Grid.RowCount
    else
      SheetRowCount := 65536;
 
    //Sheets befullen
    for M := 1 to BookCount do
    begin
      for N := 1 to SheetCount do
      begin
        //Daten aus Grid holen
        Data := VarArrayCreate([1, Grid.RowCount, 1, SheetColCount], varVariant);
        for I := 0 to SheetColCount - 1 do
          for J := 0 to SheetRowCount - 1 do
            if ((I + 256 * (N - 1)) <= Grid.ColCount) and
              ((J + 65536 * (M - 1)) <= Grid.RowCount) then
              Data[J + 1, I + 1] := Grid.Cells[I + 256 * (N - 1), J + 65536 * (M - 1)];
        //-------------------------
        XLApp.Worksheets[N].Select;
        XLApp.Workbooks[M].Worksheets[N].Name := SheetName + IntToStr(N);
        //Zellen als String Formatieren
        XLApp.Workbooks[M].Worksheets[N].Range[RefToCell(1, 1),
          RefToCell(SheetRowCount, SheetColCount)].Select;
        XLApp.Selection.NumberFormat := '@';
        XLApp.Workbooks[M].Worksheets[N].Range['A1'].Select;
        //Daten dem Excelsheet ubergeben
        Sheet := XLApp.Workbooks[M].WorkSheets[N];
        Sheet.Range[RefToCell(1, 1), RefToCell(SheetRowCount, SheetColCount)].Value :=
          Data;
      end;
    end;
    //Save Excel Worksheet
    try
      for M := 1 to BookCount do
      begin
        SaveFileName := Copy(FileName, 1,Pos('.', FileName) - 1) + IntToStr(M) +
          Copy(FileName, Pos('.', FileName),
          Length(FileName) - Pos('.', FileName) + 1);
        XLApp.Workbooks[M].SaveAs(SaveFileName);
      end;
      Result := True;
    except
      // Error ?
    end;
  finally
    //Excel Beenden
    if (not VarIsEmpty(XLApp)) and (ShowExcel = False) then
    begin
      XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
    end;
  end;
end;

//Example

procedure TForm1.Button1Click(Sender: TObject);
begin
  //StringGrid inhalt in Excel exportieren
  //Grid : stringGrid, SheetName : stringgrid Print, Pfad : c:\Test\ExcelFile.xls, Excelsheet anzeigen
  StringGridToExcelSheet(StringGrid, 'Stringgrid Print', 'c:\Test\ExcelFile.xls', True);
end;

Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php

{ **** UBPFD *********** by kladovka.net.ru ****
>> Работа с MS Excel
 
Основная функция - передача данных из DataSet в Excel
 
Зависимости: ComObj, QDialogs, SysUtils, Variants, DB
Автор:       Daun, daun@mail.kz
Copyright:   daun
Дата:        5 октября 2002 г.
********************************************** }
 
unit ExcelModule;
 
interface
 
uses ComObj, QDialogs, SysUtils, Variants, DB;
 
//**=====================================================
//** MS Excel
//**=====================================================
 
//** Открытие Excel 
procedure ExcelCreateApplication(FirstSheetName : String; //назв-е 1ого листа
                                 SheetCount : Integer; //кол-во листов
                                 ExcelVisible : Boolean);//отображение книги
 
//** Перевод номера столбца в букву, напр. 1='A',2='B',..,28='AB'
//** Должно работать до 'ZZ'
function ExcelChar(Num : Integer):String;
 
//** Оформление указанного диапазона бордерами
procedure ExcelRangeBorders(RangeBorders : Variant; //диапазон
                            BOutSideSize : Byte; //толщина снаружи
                            BInsideSize : Byte; //толщина внутри 
                            BOutSideVerticalLeft : Boolean; 
                            BOutSideVerticalRight : Boolean;
                            BInSideVertical : Boolean;
                            BOutSideHorizUp : Boolean;
                            BOutSideHorizDown : Boolean;
                            BInSideHoriz : Boolean);
 
//** Форматирование диапазона (шрифт, размер)
procedure ExcelFormatRange(RangeFormat : Variant;
                           Font : String;
                           Size : Byte;
                           AutoFit : Boolean);
//** Вывод DataSet 
procedure ExcelGetDataSet(DataSet : TDataSet;
                          SheetNumber : Integer; // Номер листа
                          FirstRow : Integer; // Первая строка
                          FirstCol : Integer; // Первый столбец
                          ShowCaptions : Boolean; // Вывод заголовков DataSet
                          ShowNumbers : Boolean; // Вывод номеров (N пп)
                          FirstNumber : Integer; // Первый номер
                          ShowBorders : Boolean; // Вывод бордюра
                          StepCol : Byte; // Шаг колонок: 0-подряд,
                                                   // 1-через одну и тд
                          StepRow : Byte); // Шаг строк
 
//** Меняет имя листа 
procedure ExcelSetSheetName(SheetNumber : Byte; //номер листа
                            SheetName : String); //имя
//** Делает Excel видимым 
procedure ExcelShow;
 
//** Сохранение книги
procedure ExcelSaveWorkBook(Name: String);
 
//**=====================================================
//** MS Word 
//**=====================================================
 
//** Открытие Ворда
procedure CreateWordAppl(WordVisible : Boolean);
 
//** Отображение Ворда
procedure MakeWordVisible;
 
//** Набор текста
procedure WordTypeText(s : String);
 
//** Новый параграф
procedure NewParag(Bold : Boolean;
                   Italic : Boolean;
                   ULine : Boolean;
                   Alignment : Integer;
                   FontSize : Integer);
 
var
 Excel,Sheet,Range,Columns : Variant;
 
 MSWord, Selection : Variant;
 
implementation
 
procedure ExcelCreateApplication(FirstSheetName : String;
                                 SheetCount : Integer;
                                 ExcelVisible : Boolean);
begin
  try
    Excel := CreateOleObject('Excel.Application');
    Excel.Application.EnableEvents := False;
    Excel.DisplayAlerts := False;
    Excel.SheetsInNewWorkbook := SheetCount;
    Excel.Visible := ExcelVisible;
    Excel.WorkBooks.Add;
    Sheet := Excel.WorkBooks[1].Sheets[1];
    Sheet.Name := FirstSheetName;
  except
    Exception.Create('Error.');
    Excel := UnAssigned;
  end;
end;
 
function ExcelChar(Num : Integer):String;
var
  S : String;
  I : Integer;
begin
  I := Trunc(Num / 26);
  if Num > 26 then S := Chr(I + 64) + Chr(Num - (I * 26) + 64)
              else S := Chr(Num + 64);
  Result := S;
end;
 
procedure ExcelRangeBorders(RangeBorders : Variant;
                            BOutSideSize : Byte;
                            BInsideSize : Byte;
                            BOutSideVerticalLeft : Boolean;
                            BOutSideVerticalRight : Boolean;
                            BInSideVertical : Boolean;
                            BOutSideHorizUp : Boolean;
                            BOutSideHorizDown : Boolean;
                            BInSideHoriz : Boolean);
begin
  if BOutSideVerticalLeft then
  begin
    RangeBorders.Borders[7].LineStyle := 1;
    RangeBorders.Borders[7].Weight := BOutSideSize;
    RangeBorders.Borders[7].ColorIndex := -4105;
  end;
  if BOutSideHorizUp then
  begin
    RangeBorders.Borders[8].LineStyle := 1;
    RangeBorders.Borders[8].Weight := BOutSideSize;
    RangeBorders.Borders[8].ColorIndex := -4105;
  end;
  if BOutSideHorizDown then
  begin
    RangeBorders.Borders[9].LineStyle := 1;
    RangeBorders.Borders[9].Weight := BOutSideSize;
    RangeBorders.Borders[9].ColorIndex := -4105;
  end;
  if BOutSideVerticalRight then
  begin
    RangeBorders.Borders[10].LineStyle := 1;
    RangeBorders.Borders[10].Weight := BOutSideSize;
    RangeBorders.Borders[10].ColorIndex := -4105;
  end;
  if BInSideVertical then
  begin
    RangeBorders.Borders[11].LineStyle := 1;
    RangeBorders.Borders[11].Weight := BInSideSize;
    RangeBorders.Borders[11].ColorIndex := -4105;
  end;
  if BInsideHoriz then begin
    RangeBorders.Borders[12].LineStyle := 1;
    RangeBorders.Borders[12].Weight := BInSideSize;
    RangeBorders.Borders[12].ColorIndex := -4105;
  end;
end;
 
procedure ExcelFormatRange(RangeFormat : Variant;
                           Font : String;
                           Size : Byte;
                           AutoFit : Boolean);
begin
  RangeFormat.Font.Name := 'Arial';
  RangeFormat.Font.Size := 7;
  if AutoFit then RangeFormat.Columns.AutoFit;
end;
 
procedure ExcelSetSheetName(SheetNumber : Byte;
                            SheetName : String);
begin
  try
    Sheet:=Excel.WorkBooks[1].Sheets[SheetNumber];
    Sheet.Name := SheetName;
  except
    Exception.Create('Error.');
    Exit;
  end;
end;
 
procedure ExcelShow;
begin
  Excel.Visible := True;
  Excel := UnAssigned;
end;
 
procedure ExcelGetDataSet(DataSet : TDataSet;
                          SheetNumber : Integer;
                          FirstRow : Integer;
                          FirstCol : Integer;
                          ShowCaptions : Boolean;
                          ShowNumbers : Boolean;
                          FirstNumber : Integer;
                          ShowBorders : Boolean;
                          StepCol : Byte;
                          StepRow : Byte);
var
  Column : Integer;
  Row : Integer;
  I : Integer;
begin
  if (ShowCaptions) and (FirstRow < 2) then FirstRow := 2;
  if (ShowNumbers) and (FirstCol < 2) then FirstCol := 2;
 
  try
    Sheet := Excel.WorkBooks[1].Sheets[SheetNumber];
  except
    Exception.Create('Error.');
    Exit;
  end;
 
  try
    with DataSet do
      try
        DisableControls;
 
        if ShowCaptions then
        begin
          Row := FirstRow - 1;
          Column := FirstCol;
          for i := 0 to FieldCount - 1 do
            if Fields[i].Visible then
            begin
              Sheet.Cells[Row, Column] := Fields[i].DisplayName;
              Inc(Column);
            end;
          Sheet.Rows[Row].Font.Bold := True;
        end;
 
        Row := FirstRow;
        First;
        while NOT EOF do
        begin
          Column := FirstCol;
          if ShowNumbers then
            Sheet.Cells[Row, FirstCol-1] := FirstNumber;
 
          for i := 0 to FieldCount - 1 do
          begin
            if Fields[i].Visible then
            begin
              if Fields[i].DataType<>ftfloat
                then Sheet.Cells[Row, Column] := Trim(Fields[i].DisplayText)
                else Sheet.Cells[Row, Column] := Fields[i].Value;
              Inc(Column, StepCol);
            end;
          end;
          Inc(Row, StepRow);
          Inc(FirstNumber);
          Next;
        end;
 
        if ShowBorders then
        begin
          if ShowCaptions then Dec(FirstRow);
          if ShowNumbers then FirstCol := FirstCol - 1;
          Range := Sheet.Range[ExcelChar(FirstCol) + IntToStr(FirstRow) +
                               ':' + ExcelChar(Column-1)+IntToStr(Row - 1)];
          if (Row - FirstRow)<2
            then ExcelRangeBorders(Range, 3, 2, True, True,
                                   True, True, True, False)
            else ExcelRangeBorders(Range, 3, 2, True, True,
                                   True, True, True, True);
          ExcelFormatRange(Range, 'Arial', 7, True);
        end;
 
      finally
        EnableControls;
      end;
  finally
  end;
end;
 
procedure ExcelSaveWorkBook(Name: String);
begin
  Excel.ActiveWorkbook.SaveAs(Name);
end;
 
 
 
procedure CreateWordAppl(WordVisible : Boolean);
begin
  try
    MsWord := GetActiveOleObject('Word.Application');
    MSWord.Documents.Add;
  except
    try
      MsWord := CreateOleObject('Word.Application');
      MsWord.Visible := WordVisible;
      MSWord.Documents.Add;
    except
      Exception.Create('Error.');
      MSWord := Unassigned;
    end;
  end;
end;
 
procedure MakeWordVisible;
begin
  MsWord.Visible := True;
  MSWord := Unassigned;
end;
 
procedure WordTypeText(S : String);
begin
  MSWord.Selection.TypeText(S);
end;
 
procedure NewParag(Bold : Boolean;
                   Italic : Boolean;
                   ULine : Boolean;
                   Alignment : Integer;
                   FontSize : Integer);
begin
  MsWord.Selection.TypeParagraph;
  MSWord.Selection.ParagraphFormat.Alignment := Alignment;
  MSWord.Selection.Font.Bold := Bold;
  MSWord.Selection.Font.Italic := Italic;
  MSWord.Selection.Font.UnderLine := ULine;
  MSWord.Selection.Font.Size := FontSize;
end;
 
end. 

Пример использования:

unit Example;
...
uses ..., ExcelModule;
...
procedure Tform1.Button1.Click(Sender: TObject);
begin
  Query1.SQL.Text := 'select * from Table';
  Query1.Open;
  ExcelCreateApplication('Example', 1, True);
  ExcelGetDataSet(Query1, 1, 1, 1, True, True, 1, True, 1, 1);
  ExcelShow;
end;
...
end.