1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; Button4: TButton; StringGrid1: TStringGrid; OpenDialog1: TOpenDialog; SaveDialog1: TSaveDialog; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Button4Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} uses ComObj; const //Координаты верхней левой ячейки ШАПКИ таблицы на листе MS Excel. cRow1 = 3; cCol1 = 2; //Очистка таблицы типа TStringGrid и сброс её размеров. procedure SgClear(aSg : TStringGrid); var Row : Integer; begin //Можно было бы чистить по столбцам - их чаще всего меньше, чем строк, //но тогда мы стёрли бы надписи в шапке таблицы. for Row := aSg.FixedRows to aSg.RowCount - 1 do aSg.Rows[Row].Clear; aSg.RowCount := aSg.FixedRows + 1; end; //Передача данных из таблицы типа TStringGrid на лист рабочей книги MS Excel. //Передаются все строки - включая фиксированные (т. е., включая шапку). //aRow, aCol - координаты верхней левой ячейки таблицы на листе MS Excel. //Функция возвращает ссылку на диапазон, в который записаны данные. function SgToExcel(aSg : TStringGrid; aExSh : Variant; const aRow, aCol : Integer) : Variant; const SelfName = 'SgToExcel()'; var exCell, exRng : Variant; vArr : Variant; i, j : Integer; begin Result := Unassigned; //Создаём вариантный массив с размером, соответствующим размеру таблицы. vArr := VarArrayCreate([1, aSg.RowCount, 1, aSg.ColCount], varOleStr); //Записываем в вариантный массив данные таблицы. for i := 1 to aSg.RowCount do for j := 1 to aSg.ColCount do vArr[i, j] := aSg.Cells[j - 1, i - 1]; //На листе MS Excel формируем диапазон, в который будут записаны данные. exCell := aExSh.Cells[aRow, aCol]; exRng := aExSh.Range[exCell, exCell.Offset[aSg.RowCount - 1, aSg.ColCount - 1]]; //Записываем данные вариантного массива в диапазон. exRng.Value := vArr; //Диапазон, в который записаны данные. Result := exRng; end; //Чтение данных с листа рабочей книги MS Excel в таблицу типа TStringGrid. //aRow, aCol - координаты верхней левой ячейки таблицы на листе MS Excel. procedure ExcelToSg(aExSh : Variant; const aRow, aCol : Integer; aSg : TStringGrid); const SelfName = 'ExcelToSg()'; //Идентификатор типа ячейки в диапазоне - последняя (справа внизу) ячейка диапазона. xlCellTypeLastCell = 11; var exRng, exCell1, exCell2 : Variant; vArr : Variant; i, j, Row : Integer; begin //Очистка StringGrid. SgClear(aSg); //Левая верхняя ячейка диапазона с данными (т. е., исключая шапку из диапазона таблицы). exCell1 := aExSh.Cells[aRow + aSg.FixedRows, aCol]; //Правая нижняя ячейка используемого диапазона на листе. {Используемый диапазон - это прямоугольная область на листе MS Excel, которая охватывает все используемые ячейки. К используемым ячейкам относятся не только те ячейки, которые содержат данные, но и те, в которых изменено оформление или в которых записаны формулы.} exCell2 := aExSh.UsedRange.SpecialCells(xlCellTypeLastCell); //Если диапазон, где должны быть данные - пуст, то выходим. if (exCell2.Row < exCell1.Row) or (exCell2.Column < exCell1.Column) then Exit; //Определяем диапазон с данными в соответствие с количеством столбцов в StringGrid. exRng := aExSh.Range[exCell1, exCell1.Offset[exCell2.Row - exCell1.Row, aSg.ColCount - 1]]; //Получаем данные диапазона в виде вариантного массива. vArr := exRng.Value; //Задаём количество строк данных (нефиксированных строк) таблицы, //равным количеству строк в диапазоне. aSg.RowCount := aSg.FixedRows + VarArrayHighBound(vArr, 1); //Копирование данных массива в ячейки нефиксированных строк таблицы. Row := aSg.FixedRows; for i := 1 to VarArrayHighBound(vArr, 1) do for j := 1 to VarArrayHighBound(vArr, 2) do aSg.Cells[j - 1, Row + i - 1] := vArr[i, j]; end; //Оформление шапки таблицы. procedure TForm1.FormCreate(Sender: TObject); var Col : Integer; Sg : TStringGrid; begin Sg := StringGrid1; //Шапка таблицы. for Col := 0 to Sg.ColCount - 1 do Sg.Cells[Col, 0] := 'TitleCol-' + FormatFloat('00', Col); end; //Запись данных на лист MS Excel. procedure TForm1.Button1Click(Sender: TObject); const //Идентификатор типа ячейки в диапазоне - последняя (справа внизу) ячейка диапазона. xlCellTypeLastCell = 11; //Толщина линий. xlThin = 2; xlMedium = -4138; //Вид линии. xlContinuous = 1; //Непрерывная линия. var exApp, exBook, exSh, exRng, exRngTmp : Variant; i : Integer; Sg : TStringGrid; Sd : TSaveDialog; begin Sg := StringGrid1; Sd := SaveDialog1; //SaveDialog1 уже должен быть на форме. if Sd.InitialDir = '' then Sd.InitialDir := ExtractFilePath( ParamStr(0) ); if not Sd.Execute then Exit; if FileExists(Sd.FileName) then begin i := MessageBox(0, 'Файл с заданным именем уже существует. Перезаписать?' ,'Перезаписать?', MB_YESNO + MB_ICONQUESTION + MB_APPLMODAL); if i = IDNO then Exit; end; //Попытка подключиться к корневому объекту MS Excel. try exApp := CreateOleObject('Excel.Application'); except MessageBox(0, 'Не удалось запустить MS Excel. Действие отменено.', 'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL); Exit; end; //Делаем видимым окно MS Excel. exApp.Visible := True; //Создаём рабочую книгу. exBook := exApp.WorkBooks.Add; //Получаем ссылку на первый лист рабочей книги. exSh := exBook.Worksheets[1]; //Для ускорения работы с MS Excel отключаем режим перерисовки окон MS Excel. exApp.ScreenUpdating := False; try //Передаём данные из таблицы на лист MS Excel. Функция возвращает ссылку //на интерфейс диапазона, в который записались данные таблицы. exRng := SgToExcel(Sg, exSh, cRow1, cCol1); //Здесь можно произвести оформление диапазона. - Линовка, выравнивание //ширины столбцов, параметры шрифта и пр. if not VarIsClear(exRng) then begin {Шапка.} //Получаем диапазон шапки. exRngTmp := exRng.Rows[1]; for i := 1 + 1 to Sg.FixedRows do exRngTmp := exApp.Union(exRngTmp, exRng.Rows[i]); //Шрифт - жирный. exRngTmp.Font.Bold := True; //Обрамление ячеек. exRngTmp.Borders.LineStyle := xlContinuous; exRngTmp.Borders.Weight := xlMedium; {Строки данных.} //Получаем диапазон без шапки - только строки данных таблицы MS Excel. exRngTmp := exApp.Intersect(exRng, exRng.Offset[Sg.FixedRows, 0]); //Обрамление ячеек. exRngTmp.Borders.LineStyle := xlContinuous; exRngTmp.Borders.Weight := xlThin; {Вся таблица.} //Подбор ширины столбцов по содержимому. exRng.Columns.AutoFit; end; finally //Включаем режим перерисовки окон MS Excel. exApp.ScreenUpdating := True; end; //Сохраняем рабочую книгу. //Отключаем режим предупреждений. - Чтобы не выводился диалог о перезаписи //файла, если он уже существует. exApp.DisplayAlerts := False; try exBook.SaveAs(FileName:=Sd.FileName); finally //Включаем режим предупреждений. exApp.DisplayAlerts := True; end; //Закрытие рабочей книги MS Excel. //exBook.Close; //Выход из MS Excel. //exApp.Quit; end; //Чтение данных с листа MS Excel. procedure TForm1.Button2Click(Sender: TObject); var exApp, exBook, exSh : Variant; Sg : TStringGrid; Od : TOpenDialog; begin Sg := StringGrid1; Od := OpenDialog1; //OpenDialog1 уже должен быть на форме. if Od.InitialDir = '' then Od.InitialDir := ExtractFilePath( ParamStr(0) ); if not Od.Execute then Exit; if not FileExists(Od.FileName) then begin MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.' ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL); Exit; end; //Попытка подключиться к корневому объекту MS Excel. try exApp := CreateOleObject('Excel.Application'); except MessageBox(0, 'Не удалось запустить MS Excel. Действие отменено.', 'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL); Exit; end; //Делаем видимым окно MS Excel. На время отладки или на постоянной основе. exApp.Visible := True; //Открываем файл рабочей книги. exBook := exApp.WorkBooks.Open(FileName:=Od.FileName); //Получаем ссылку на первый лист рабочей книги. exSh := exBook.Worksheets[1]; //Получаем данные с листа рабочей книги MS Excel и записываем их //в нефиксированные строки таблицы. ExcelToSg(exSh, cRow1, cCol1, Sg); end; //Заполнение таблицы данными. procedure TForm1.Button3Click(Sender: TObject); var i, Row, Col : Integer; Sg : TStringGrid; begin Sg := StringGrid1; Randomize; SgClear(Sg); Sg.RowCount := Sg.FixedRows + Random(100); i := 0; for Row := Sg.FixedRows to Sg.RowCount - 1 do begin Inc(i); //Номер строки данных. Sg.Cells[0, Row] := FormatFloat('000', i); for Col := 0 + 1 to Sg.ColCount - 1 do Sg.Cells[Col, Row] := 'Data-' + FormatFloat('000', Random(1000)); end; end; //Очистка таблицы. procedure TForm1.Button4Click(Sender: TObject); begin SgClear(StringGrid1); end; end. |
Модератор: Модераторы
Re: StringGrid экспорт данных Excel
Извиняюсь, что прямо с первого сообщения вмешиваюсь.
Есть самодельный модуль XLSX, который делает то, что вам, Gampos, нужно.
Сохранить StringGrid1 в файл Excel можно как-то так:
- Код: Выделить всё
procedure TForm1.BtnCopyFromGridClick(Sender: TObject);
var
WB: TWorkBook;
WS: TWorkSheet;
begin
WB:= TWorkBook.Create;
WS:=WB.AddWorkSheet;
WS.LoadFromStringGrid(StringGrid1);
WB.SaveToFile('Filename.xlsx');
WB.Free;
end;
TWorkBook, TWorkSheet — объявлены в модуле.
Наличия в системе установленного MS Office не требуется.
(сохранить можно только в файл xlsx)
Если интересно, могу выслать исходник.
- waydm
- незнакомец
- Сообщения: 3
- Зарегистрирован: 27.04.2013 14:03:18
- Откуда: Саратов
Re: StringGrid экспорт данных Excel
Gampos » 27.04.2013 14:57:08
Попробовал сохранить Grid в .csv , выдал кодировку ANSI as UTF-8….теперь буду пробовать менять кодировку в гриде.. посмотрю что получится…Обзательно отпишусь..
Добавлено спустя 5 минут 53 секунды:
waydm , конечно интересно.. если Вам не сложно был бы рад исходнику))
-
Gampos - новенький
- Сообщения: 17
- Зарегистрирован: 25.04.2013 08:24:40
- Откуда: Владивосток
-
- Профиль
- Сайт
Re: StringGrid экспорт данных Excel
Владимир » 27.04.2013 15:14:43
Gampos писал(а):был бы рад исходнику
Добавлять чужие модули в свой проект можно, если нет другого выхода и если понимаешь, что и как в нем делается. Старайся по возможности использовать штатные средства Лазаруса. Кроме того, не уверен, что в модуле waydm автоматом будет преобразование кодировок (могу ошибаться).
Ты в двух шагах от результата! Должно получиться — сначала Grid в UTF8, затем — в ansi.
- Владимир
- постоялец
- Сообщения: 329
- Зарегистрирован: 23.08.2007 19:48:39
- Откуда: Москва
Re: StringGrid экспорт данных Excel
waydm » 27.04.2013 17:15:48
Gampos, ок, скиньте в личку свою почту.
Владимир, все от начала до конца в UTF-8, ничего преобразовывать не требуется.
А на счет приоритетного использования штатных средств — вы безусловно правы. Но, иногда, все же приходится отступать от этого правила.
- waydm
- незнакомец
- Сообщения: 3
- Зарегистрирован: 27.04.2013 14:03:18
- Откуда: Саратов
Re: StringGrid экспорт данных Excel
Владимир » 27.04.2013 17:35:19
waydm писал(а): все от начала до конца в UTF-8
Добавлено спустя 15 часов 46 минут 26 секунд:
Gampos писал(а):буду пробовать менять кодировку
Последний раз редактировалось Владимир 29.04.2013 21:32:23, всего редактировалось 1 раз.
- Владимир
- постоялец
- Сообщения: 329
- Зарегистрирован: 23.08.2007 19:48:39
- Откуда: Москва
Re: StringGrid экспорт данных Excel
*Rik* » 29.04.2013 12:38:05
Gampos писал(а):Спасибо *Rik* , первоклассный исходник, наглядно показано,
Попробовал от Владимира код импортировать, превосходно выходит. Спасибо.Не сочтите за наглость, но можете посоветовать, как правильно указать кодировку, при экспорте данных из стринг грид (версия лазаруса 1.0. 8 ).
На выходе в ксв получается (кракозябры). Если потом импортировать в ексель, с указанием уникод УТФ8, буквы становятся нормальными.
Можно ли при экспорте в ксв принудительно задать эту кодировку?
- Код: Выделить всё
Дата в„– колект Нач.смены Смена Р СѓРґР°Zn Р СѓРґР°Pb ХвТехZn ХвТехPb КонЦинZn КонЦинPb КонЦинFe РљРѕРЅРЎРІZn РљРѕРЅРЎРІPb РҐРІРўРѕРІZn РҐРІРўРѕРІPb РежРР·1СЃС‚ РежРР·2СЃС‚ РежРР·РљР»+315 Р’Р»Zn Р’Р»Pb Примечание
27.04.2013 вт? Мудрецова дне 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5 5,5
Запрещено файлы передавать, — содержимое ксв файла.
UTF8Decode(‘строка’)????
-
*Rik* - постоялец
- Сообщения: 409
- Зарегистрирован: 19.04.2011 12:18:51
- Откуда: Урал
-
- Профиль
- Сайт
Re: StringGrid экспорт данных Excel
Vadim » 29.04.2013 12:58:17
А Excel какой версии? 2010-ый хранит строки в кодировке UTF-8.
- Vadim
- долгожитель
- Сообщения: 4112
- Зарегистрирован: 05.10.2006 08:52:59
- Откуда: Красноярск
Re: StringGrid экспорт данных Excel
Gampos » 29.04.2013 15:06:04
Долго колдовал над кодировками, наконец-то получилось:)))) делюсь кодом, который экспортирует данные из стринг грида в ексель с нормальными буквами, без всяких кроказябр…..
- Код: Выделить всё
procedure TForm1.Button24Click(Sender: TObject);
var str,s:WideString;
exl:OleVariant;
i,j:integer;begin
exl:=CreateOleObject('Excel.Application');
WorkBook:=exl.Application.WorkBooks.Add;
Sheet:=exl.WorkBooks[1].Sheets[1];
for i:=0 to StringGrid1.RowCount-1 do
for j:=0 to StringGrid1.ColCount-1 do
begin
s:=UTF8ToAnsi(StringGrid1.Cells[j,i]);
Sheet.Cells(i+1,j+1):= (s);
end;
exl.visible:=true;
exl.application.activeWorkBook.Save;
Спасибо огромное еще раз всем за помощь)))
-
Gampos - новенький
- Сообщения: 17
- Зарегистрирован: 25.04.2013 08:24:40
- Откуда: Владивосток
-
- Профиль
- Сайт
Re: StringGrid экспорт данных Excel
Владимир » 29.04.2013 15:43:33
Gampos писал(а):без всяких кроказябр
Что-то не так.
- Код: Выделить всё
var
s:WideString;
....................
//это работает
s:=UTF8ToAnsi(StringGrid1.Cells[j,i]);
Sheet.Cells(i+1,j+1):= (s);//зачем здесь скобки?//это не работает
s:=StringGrid1.Cells[j,i];
Sheet.Cells(i+1,j+1):=UTF8ToAnsi(s);
Кто-нидь объяснит?
- Владимир
- постоялец
- Сообщения: 329
- Зарегистрирован: 23.08.2007 19:48:39
- Откуда: Москва
Re: StringGrid экспорт данных Excel
amateur » 29.04.2013 15:58:24
Ужасная идея завязываться на оле (сугубо личное).
Почему не воспользоваться готовым, вполне рабочим FPSpreadsheet. Там ведь все в комплекте, вплоть до того в какую версию экселя выводить. Единственное чем не понравился — «тугая» работа опенофисом.
-
amateur - энтузиаст
- Сообщения: 552
- Зарегистрирован: 03.08.2007 10:15:32
Re: StringGrid экспорт данных Excel
Mr.Smart » 29.04.2013 16:13:30
Скобки лишние.
Здесь проблема в преобразовании типов между String и WideString.
Пробуйте так:
- Код: Выделить всё
Sheet.Cells(i+1,j+1):=WideString(UTF8ToAnsi(s));
- Mr.Smart
- долгожитель
- Сообщения: 1796
- Зарегистрирован: 29.03.2008 01:01:11
- Откуда: из леса!
Re: StringGrid экспорт данных Excel
Владимир » 29.04.2013 17:57:33
Mr.Smart писал(а):Здесь проблема в преобразовании типов между String и WideString.
Где-то здесь на форуме проскочило, что UTF8ToAnsi работает только с WideString (для кириллицы). Как умная Маша, пишу
- Код: Выделить всё
var
s:WideString;
...............
s:='Текст';
Sheet.Cells[1,1]:=UTF8ToAnsi(s);
В Excel получаю нормально «Текст»
Делаю то же с ячейками StringGrid — получаю бред.
- Владимир
- постоялец
- Сообщения: 329
- Зарегистрирован: 23.08.2007 19:48:39
- Откуда: Москва
Re: StringGrid экспорт данных Excel
wwswowsogon » 13.07.2015 21:33:33
Mr.Smart писал(а):Скобки лишние.
Здесь проблема в преобразовании типов между String и WideString.
Пробуйте так:
- Код: Выделить всё
Sheet.Cells(i+1,j+1):=WideString(UTF8ToAnsi(s));
Спасибо!
Вы спасли моё положение
Всё работает, как надо!
- wwswowsogon
- постоялец
- Сообщения: 125
- Зарегистрирован: 23.12.2008 20:41:37
Вернуться в Lazarus
Кто сейчас на конференции
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 4
19th
Июн
Posted by Chas under Delphi
На форме имеется таблица StringGrid, состоящая из нескольких сотен строк и 6 столбцов. Также есть Edit1, в который вводится имя файла. Нужно организовать возможность сохранения данных из этой таблицы в Excel.
А именно, при нажатии на кнопку «Сохранить» данные из СтрингГрида должны вывестись на лист книги Excel, а затем эта книга должна сохраниться в директорию с программой с названием, которое введено в Edit1.
Daramant
Это можно сделать вот так:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids;type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }function GetExcelFileName: String;
public
{ Public declarations }
end;var
Form1: TForm1;implementation
{$R *.dfm}
uses
ComObj;const
EXCEL_FILE_EXT = '.xls';function TForm1.GetExcelFileName: String;
begin
Result := ExtractFilePath(Application.ExeName) + Edit1.Text;if LowerCase(ExtractFileExt(Result)) <> EXCEL_FILE_EXT then
Result := Result + EXCEL_FILE_EXT;
end;procedure TForm1.Button1Click(Sender: TObject);
var
ExcelApp, Sheet: variant;
Col, Row: Word;
begin
ExcelApp := CreateOleObject('Excel.Application');
try
ExcelApp.Visible := false;ExcelApp.Workbooks.Add;
Sheet := ExcelApp.ActiveWorkbook.Worksheets[1];for Col := 0 to StringGrid1.ColCount - 1 do
for Row := 0 to StringGrid1.RowCount - 1 do
Sheet.Cells[Row + 1, Col + 1] := StringGrid1.Cells[Col, Row];ExcelApp.ActiveWorkbook.SaveAs(GetExcelFileName);
ShowMessage('Ok!');
finally
ExcelApp.Application.Quit;
ExcelApp := unassigned;
end;
end;
end.
тема на форуме
Похожие статьи
- Сохранить stringGrid в Excel
- Как добавить таблицу из StringGrid в excel?
- Сравнение двух диапазонов ячеек Excel на полное совпадение данных
- Что в календаре Excel возвращает дату?
- Как закрыть папку в Excel средствами VBA без имитации нажатия клавиш?
- Реакция на клик по ячейке в Excel
- Как в Excel сделать так, чтобы при нажатии на ячейку менялось цифровое значение?
- Cчитывание измеренной температуры с датчика DS18B20 в Excel, используя библиотеку RSAPI.DLL
- Интерфейс между Outlook и Excel
- Как в Excel убрать панель формул с определенного окна?
The problem is that you are calling the Excel object for every cell; this is a slow operation at the best of times, so doing this for a large number of cells is going to take a long time. I had a case of this not so long ago: 4000 rows with 9 columns took about 44 seconds to transfer to Excel.
My current solution involves creating a csv file then importing that csv into Excel.
const
fn = 'c:windowstempcsv.csv';
var
csv: tstringlist;
row, col: integer;
s: string;
begin
csv:= tstringlist.create;
for row:= 1 to stringgrid1.rowcount do
begin
s:= '';
for col:= 0 to stringgrid1.ColCount-1 do
s:= s + stringgrid1.Cells[col, row-1] + ',';
csv.add (s)
end;
csv.savetofile (fn);
csv.free;
objExcel := TExcelApplication.Create(nil);
objExcel.workbooks.open (fn);
deletefile (fn);
end;
Another way comes from Mike Shkolnik which I am quoting as is:
var
xls, wb, Range: OLEVariant;
arrData: Variant;
begin
{create variant array where we'll copy our data}
arrData := VarArrayCreate([1, yourStringGrid.RowCount, 1, yourStringGrid.ColCount], varVariant);
{fill array}
for i := 1 to yourStringGrid.RowCount do
for j := 1 to yourStringGrid.ColCount do
arrData[i, j] := yourStringGrid.Cells[j-1, i-1];
{initialize an instance of Excel}
xls := CreateOLEObject('Excel.Application');
{create workbook}
wb := xls.Workbooks.Add;
{retrieve a range where data must be placed}
Range := wb.WorkSheets[1].Range[wb.WorkSheets[1].Cells[1, 1],
wb.WorkSheets[1].Cells[yourStringGrid.RowCount, yourStringGrid.ColCount]];
{copy data from allocated variant array}
Range.Value := arrData;
{show Excel with our data}
xls.Visible := True;
end;
I suggest that you try both methods and see which is faster for your purposes.
01.01.2007
{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:TestExcelFile.xls, Excelsheet anzeigen StringGridToExcelSheet(StringGrid, 'Stringgrid Print', 'c:TestExcelFile.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.