Показать сообщение отдельно
  #4  
Старый 18.05.2010, 12:17
Аватар для Aristarh Dark
Aristarh Dark Aristarh Dark вне форума
Модератор
 
Регистрация: 07.10.2005
Адрес: Москва
Сообщения: 2,906
Версия Delphi: Delphi XE
Репутация: выкл
По умолчанию

Немного дополнил (пока beta):
Код:
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.
__________________
Некоторые программисты настолько ленивы, что сразу пишут рабочий код.

Если вас наказали ни за что - радуйтесь: вы ни в чем не виноваты.
Ответить с цитированием