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

== Через 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;
== Без использования 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;
== 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;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04376
----
== Передача данных из DataSet в Excel ==
{ **** UBPFD *********** by kladovka.net.ru ****
>> Работа с MS Excel
Основная функция - передача данных из DataSet в Excel
Зависимости: ComObj, QDialogs, SysUtils, Variants, DB
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.
Пример использования:
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;
Author: Daun, daun@mail.kz
ID: 04377
Category:COM
Category:MS Office