Как stringgrid сохранить в excel

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. 

Понравилась статья? Поделить с друзьями:
  • Как sqlite открыть в excel
  • Как sql запрос выгрузить в excel
  • Как rtf перевести в word онлайн
  • Как replace excel vba
  • Как rar переделать в word