Форум по Delphi программированию

Delphi Sources



Вернуться   Форум по Delphi программированию > Все о Delphi > Базы данных
Ник
Пароль
Регистрация <<         Правила форума         >> FAQ Пользователи Календарь Поиск Сообщения за сегодня Все разделы прочитаны

 
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 14.05.2010, 09:25
Аватар для Aristarh Dark
Aristarh Dark Aristarh Dark вне форума
Модератор
 
Регистрация: 07.10.2005
Адрес: Москва
Сообщения: 2,907
Версия Delphi: Delphi XE
Репутация: выкл
По умолчанию Передача данных в 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
unit ExportToExcel;
{
  Модуль для передачи данных в Excel из любого наследника TDataSet
 
  (c) Aristarh Dark (2010)
  e-mail: aristarh.dark@gmail.com
 
  Зависимости:
  DB, SysUtils, ComObj, Variants, Math;
 
  Небольшое описание:
  ds              - набор данных по которому надо построить таблицу в эксель
  TableName       - выводимый заголовок таблицы
  Names           - вариантрый массив имен столбцов, имена должны следовать в том же
                    порядке, что и выводимые поля в наборе данных
  NotOut          - вариантный массив имен полей набора данных которые выводить не
                    следует, поля в массиве следовали в том же порядке что и в наборе
  isDeletePresent - это моя собственная примочка, т.к. в любой таблице я использую
                    поле isDeleted (признак удаленной записи), то такие записи я
                    хотел бы видеть и в результирующей таблице в Excel. В моем
                    варианте они выделяются курсивом.
 
  Модуль свободен для использования и изменения, ссылка на автора желательна
 
  Тестировалось на Excel 2003
}
interface
uses
  DB;
 
procedure ToExcel(ds:TDataSet;TableName:String;Names,NotOut:Variant;isDeletePresent:boolean = True);
 
implementation
uses
  SysUtils, ComObj, Variants, Math;
 
const
  TitleRow          = '2';
  TitleCol          = 'B';
  TitleFontName     = 'Times New Roman';
  TitleFontSize     = 12;
 
  TableHeadRow      = '4';
  TableHeadStartCol = 'B';
  TableHeadFontName = 'Courier New';
  TableHeadFontSize = 12;
 
  TableDataStartRow = '5';
  TableDataStartCol = 'B';
  TableDataFontName = 'Courier New';
  TableDataFontSize = 12;
 
function ExInc(value:string;delta:integer = 1;trend:boolean = true):string;
{
   Сложение/вычитание координат Excel
   value - значение (буквенная координата столбца)
   delta - коэффициент приращения [1]
   trend - направление приращения .t. - сложение, .f. - вычитание [.t.]
 
   ВНИМАНИЕ!!
   работает только до 'ZZ'
}
var
  numeric:integer;
  low,hig:integer;
begin
  if not(trend) then
    delta:=delta*(-1);
  //распаковка
  if Length(value)>1 then
     numeric:=(ord(value[1])-64)*26+(ord(value[2])-64)
  else
     numeric:=ord(value[1])-64;
  numeric:=numeric+delta;
  //упаковка
  if numeric>26 then
    begin
      low:=numeric-(26*Trunc(numeric/26));
      hig:=Trunc(numeric/26);
      if low=0 then
        begin
          low:=26;
          hig:=hig-1;
        end;
      result:=chr(hig+64)+chr(low+64);
    end
  else
     result:=chr(64+numeric);
end;
 
 
function CheckField(FieldName:string;Data:Variant):boolean;
var
  i:integer;
begin
  Result:=True;
  for i:=VarArrayLowBound(data,1) to VarArrayHighBound(data,1) do
    if AnsiUpperCase(FieldName)=AnsiUpperCase(data[i]) then
      Result:=False;
end;
procedure ToExcel(ds:TDataSet;TableName:String;Names,NotOut:Variant;isDeletePresent:boolean = True);
var
  Excel:OleVariant;
  Sheet:OleVariant;
  Data:Variant;
  i,j:integer;
  counter:integer;
  NoOutFieldsPresent:boolean;
  NoOutCounter:integer;
  NoOutCounterNeedInc:boolean;
  TableWidth:integer;
  RangeStr:String;
begin
  NoOutFieldsPresent:=False;
  //Предварительная подготовка
  Excel:=CreateOleObject('Excel.Application');
  Excel.WorkBooks.Add;
  Sheet:=Excel.WorkBooks[1].ActiveSheet;
  Excel.Visible:=True;
  //Наименования стролбцов
  if VarType(Names) and VarArray = VarArray then
    begin
      //Вывод наименований столбцов
      counter:=0;
      for i:=VarArrayLowBound(Names,1) to VarArrayHighBound(Names,1) do
        begin
          RangeStr:=Format('%s%s',[ExInc(TableHeadStartCol,counter),TableHeadRow]);
          Sheet.Range[RangeStr].Value:=Names[i];
          Sheet.Range[RangeStr].HorizontalAlignment:=$FFFFEFF4;
          Sheet.Range[RangeStr].VerticalAlignment:=$FFFFEFF4;
          Sheet.Range[RangeStr].Font.Bold:=True;
          Sheet.Range[RangeStr].Font.Name:=TableHeadFontName;
          Sheet.Range[RangeStr].Font.Size:=TableHeadFontSize;
          inc(Counter);
        end;
    end;
  //"Невыводимые" поля
  if VarType(NotOut) and VarArray = VarArray then
    begin
      Data:=VarArrayCreate([1,ds.RecordCount,1,ds.Fields.Count-VarArrayHighBound(NotOut,1)],varVariant);
      NoOutFieldsPresent:=true;
    end
  else
    Data:=VarArrayCreate([1,ds.RecordCount,1,ds.Fields.Count],varVariant);
  //Расчет "ширины" таблицы, очевидна что она будет равна количеству столбцов
  TableWidth:=VarArrayHighBound(data,2);
  //Наименование таблицы
  Sheet.Range[Format('%s%s',[TitleCol,TitleRow])].Value:=TableName;
  RangeStr:=Format('%s%s:%s%s',[TitleCol,TitleRow,ExInc(TitleCol,TableWidth-1),TitleRow]);
  Sheet.Range[RangeStr].Merge;
  Sheet.Range[RangeStr].HorizontalAlignment:=$FFFFEFF4;
  Sheet.Range[RangeStr].VerticalAlignment:=$FFFFEFF4;
  Sheet.Range[RangeStr].Font.Bold:=True;
  Sheet.Range[RangeStr].Font.Name:=TitleFontName;
  Sheet.Range[RangeStr].Font.Size:=TitleFontSize;
  NoOutCounter:=1;
  NoOutCounterNeedInc:=False;
  for i:=1 to ds.Fields.Count do
    begin
      ds.First;
      if NoOutCounterNeedInc then
        begin
          inc(NoOutCounter);
          NoOutCounterNeedInc:=False;
        end;
      for j:=1 to ds.RecordCount do
        begin
          if NoOutFieldsPresent then
            begin
              if CheckField(ds.Fields[i-1].FieldName,NotOut) then
                begin
                  Data[j,NoOutCounter]:=ds.Fields[i-1].Value;
                  NoOutCounterNeedInc:=True;
                end;
            end
          else
            begin
              Data[j,i]:=ds.Fields[i-1].Value;
            end;
          ds.Next;
        end
    end;
  if VarType(NotOut) and VarArray = VarArray then
    begin
      RangeStr:=Format('%s%s:%s%d',[TableDataStartCol,TableDataStartRow,chr(65+IfThen(NoOutFieldsPresent,ds.Fields.Count-VarArrayHighBound(NotOut,1),ds.Fields.Count)),4+ds.RecordCount]);
      Sheet.Range[RangeStr].Value:=Data;
    end
  else
    begin
      RangeStr:=Format('%s%s:%s%d',[TableDataStartCol,TableDataStartRow,chr(65+ds.Fields.Count),4+ds.RecordCount]);
      Sheet.Range[RangeStr].Value:=Data;
    end;
  //Украшательство
  Sheet.Range[RangeStr].Font.Name:=TableDataFontName;
  Sheet.Range[RangeStr].Font.Size:=TableDataFontSize;
  //Удаленнные записи
  if isDeletePresent then
    begin
      ds.First;
      for i:=1 to ds.RecordCount do
        begin
          if ds.FieldByName('isDeleted').AsBoolean then
            begin
              //Рассчет нахождения удаленной строки
              RangeStr:=Format('%d:%d',[StrToInt(TableDataStartRow)+i-1,StrToInt(TableDataStartRow)+i-1]);
              //Украшалка
              Sheet.Range[RangeStr].Font.Italic:=True;
            end;
          ds.Next;
        end;
    end;
  //Последнее украшательство
  Sheet.Cells.Select;
  Sheet.Cells.EntireColumn.AutoFit;
  Sheet.Range['A1'].Select;
end;
 
end.
__________________
Некоторые программисты настолько ленивы, что сразу пишут рабочий код.

Если вас наказали ни за что - радуйтесь: вы ни в чем не виноваты.
Ответить с цитированием
Эти 4 пользователя(ей) сказали Спасибо Aristarh Dark за это полезное сообщение:
gewasop (06.05.2015), kucher (20.10.2015), Yurk@ (18.02.2013), Малая (06.03.2015)
 


Delphi Sources

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB-коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Быстрый переход


Часовой пояс GMT +3, время: 11:07.


 

Сайт

Форум

FAQ

Соглашения

Прочее

 

Copyright © Форум "Delphi Sources" by BrokenByte Software, 2004-2025