unit ExportToExcel;
{
Модуль для передачи данных в Excel из любого наследника TDataSet
(c) Aristarh Dark (2010)
e-mail: aristarh.dark@gmail.com
ver 2.0 beta
Зависимости:
DB, SysUtils, ComObj, Variants, Math;
Небольшое описание:
ds - набор данных по которому надо построить таблицу в эксель
TableName - выводимый заголовок таблицы
Names - вариантрый массив имен столбцов, имена должны следовать в том же
порядке, что и выводимые поля в наборе данных
NotOut - вариантный массив имен полей набора данных которые выводить не
следует, поля в массиве следовали в том же порядке что и в наборе
Total - вариантный массив имен полей набора данных для которых следует
подсчитать общий итог по столбцу. Поля должны следовать в томже
порядке, что и в наборе.
ФИЧИ:
1. Предпологается что первый столбец не суммируется (в него пишется ИТОГО)
2. Пока не работает для таких наборов данных в которых есть невыводимые поля,
т.е. массив NoOut должен быть пуст (или не массив ;))
isDeletePresent - это моя собственная примочка, т.к. в любой таблице я использую
поле isDeleted (признак удаленной записи), то такие записи я
хотел бы видеть и в результирующей таблице в Excel. В моем
варианте они выделяются курсивом.
Модуль свободен для использования и изменения, ссылка на автора желательна
Тестировалось на Excel 2003
Тестировалось на Excel 2007
}
interface
uses
DB;
procedure ToExcel(ds:TDataSet;TableName:String;Names,NotOut,Total: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;
GrandTotalFontName = 'Courier New';
GrandTotalFontSize = 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 GetTotalFieldPos(FieldName:string;Data:Variant):integer;
var
i:integer;
begin
Result:=-1;
for i:=VarArrayLowBound(data,1) to VarArrayHighBound(data,1) do
if AnsiUpperCase(FieldName)=AnsiUpperCase(data[i]) then
Result:=i;
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,Total:Variant;isDeletePresent:boolean = True);
var
Excel:OleVariant;
Sheet:OleVariant;
Data:Variant;
GrandTotal:Variant;
GrandTotalOut:Variant;
i,j:integer;
gtPos:integer;
counter:integer;
NoOutFieldsPresent:boolean;
NoOutCounter:integer;
NoOutCounterNeedInc:boolean;
GrandTotalPresent:boolean;
TableWidth:integer;
RangeStr:String;
begin
NoOutFieldsPresent:=False;
GrandTotalPresent:=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);
//Нужно ли рассчитывать ИТОГИ
if VarType(Total) and VarArray = VarArray then
begin
GrandTotal:=VarArrayCreate([1,VarArrayHighBound(Total,1)],varVariant);
GrandTotalPresent:=True;
end;
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;
if GrandTotalPresent and (GetTotalFieldPos(ds.Fields[i-1].FieldName,Total)>0) then
GrandTotal[GetTotalFieldPos(ds.Fields[i-1].FieldName,Total)]:=
GrandTotal[GetTotalFieldPos(ds.Fields[i-1].FieldName,Total)]+ds.Fields[i-1].Value;
end;
end
else
begin
Data[j,i]:=ds.Fields[i-1].Value;
if GrandTotalPresent then
begin
gtPos:=GetTotalFieldPos(ds.Fields[i-1].FieldName,Total);
if gtPos>0 then
GrandTotal[gtPos]:=GrandTotal[gtPos]+ds.Fields[i-1].Value;
end;
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;
//Вывод итогов
if GrandTotalPresent then
begin
//Создаем массив равный по ширине таблице, а по высоте в 1 строку
GrandTotalOut:=VarArrayCreate([1,1,1,TableWidth],varVariant);
//Переносим значения в "правильные" ячейки массива
i:=0;
j:=1;
while i<ds.FieldCount do
begin
if NoOutFieldsPresent then
begin
//Здесь надо проработать
end
else
begin
if GetTotalFieldPos(ds.Fields[i].FieldName,total)>0 then
begin
GrandTotalOut[1,i+1]:=GrandTotal[j];
inc(j);
end
end;
inc(i);
end;
//Предполагается что первый столбец в таблице не суммируется
GrandTotalOut[1,1]:='ИТОГО:';
//Расчет позиции вывода массива
RangeStr:=Format('%s%d:%s%d',[TableDataStartCol,StrToInt(TableDataStartRow)+ds.RecordCount,
ExInc(TableHeadStartCol,TableWidth-1),StrToInt(TableDataStartRow)+ds.RecordCount]);
Sheet.Range[RangeStr].Value:=GrandTotalOut;
Sheet.Range[RangeStr].Font.Name:=GrandTotalFontName;
Sheet.Range[RangeStr].Font.Size:=GrandTotalFontSize;
Sheet.Range[RangeStr].Font.Bold:=True;
end;
Sheet.Cells.Select;
Sheet.Cells.EntireColumn.AutoFit;
Sheet.Range['A1'].Select;
end;
end.