Передача данных в Excel

Aristarh Dark · #1 14.05.2010, 09:25

Этот вопрос очень часто задают на форуме. Я решил не жадничать и поделиться небольшой своей наработкой. Т.к. много писать я не люблю смотрите код:

Код:

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.

Страдалецъ · #2 14.05.2010, 11:18

Добавьте еще пример вызова.

Aristarh Dark · #3 15.05.2010, 05:19

Страдалецъ, вот Вы и напишите, в Ваших способностях я не сомневаюсь

Aristarh Dark · #4 18.05.2010, 12:17

Немного дополнил (пока 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.

netruxa · #5 23.05.2010, 12:58

Вот как я делаю экспорт... Вроде попроще код, может кому пригодится

Код:

procedure TfMain.Button5Click(Sender: TObject);
var
 XL, XArr: Variant;
 i: Integer;
 j: Integer;
begin
XArr:=VarArrayCreate([1,DM.qTabl1.FieldCount],varVariant);
 XL:=CreateOLEObject('Excel.Application');     
 XL.WorkBooks.add;

 XL.Range['A1','A1'].Value := 'заголовок 1';
  XL.Range['B1','B1'].Value := '...';


 j := 2;
 DM.qTabl1.First;
 while not DM.qTabl1.Eof do
  begin
   i:=1;
   while i<=DM.qTabl1.FieldCount do
    begin
     XArr[i] := DM.qTabl1.Fields[i-1].Value;
     i := i+1;
    end;
      XL.Range['A'+IntToStr(j),
   CHR(64+DM.qTabl1.FieldCount)+IntToStr(j)].Value := XArr;
   DM.qTabl1.Next;
   j:=j+1;
  end;


 XL.Range['A1',CHR(64+DM.qTabl1.FieldCount)+IntToStr(j)].select;

 XL.Selection.Font.Name:='Arial cur';
 XL.Selection.Font.Size:=10;
 XL.Selection.ColumnWidth:=10;
 XL.Selection.RowHeight:=15;

   with SaveDialog1 do
      if Execute then
      xl.ActiveWorkbook.SaveAs(FileName);


 XL.Range['A1','A1'].select;
  XL.visible:=true;
end;

Deadwoolf · #6 13.08.2010, 02:16

помогите кто может.. делаю программу в которой будет много значений каторые динамически обновляюца ну ето не важно. дапустим нада 3 значения постоянно экспортировать в эксель как бы лог такой что бы в эксели ани шли (время....данные1....данные2...данные3) такова вида. и при желании пользователя данные выводились в программе дапустим он выбрал определенный день и ему программа паказала какие данные были занесены в етот день... заранее огромное спасибо!!!

Deadwoolf · #7 18.08.2010, 03:13

разобрался с экспортом в бд использую аксес ( оказалось все намного проще чем думал )

ProFFi07 · #8 05.09.2010, 23:27

Доброго суток дня, народ.
При переносе данных в excel, в ячейках где добавлены данные c dbmemo после каждой строки отображается квадратный символ т.е. в dbmemo - это был перенос строки (путём enter).
Как мне сделать эти квадратные символы невидимыми?
Помогите плизз.

Aristarh Dark · #9 06.09.2010, 05:24

Заменить перед выводом на пробел

alex_rR · #10 15.05.2012, 16:03

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	RSS лента	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Новости сайта Новости форума	Ссылки и Баннеры Donate О сайте Реклама Контакты

Эти 4 пользователя(ей) сказали Спасибо Aristarh Dark за это полезное сообщение:
gewasop (06.05.2015), kucher (20.10.2015), Yurk@ (18.02.2013), Малая (06.03.2015)

Эти 2 пользователя(ей) сказали Спасибо Aristarh Dark за это полезное сообщение:
gewasop (06.05.2015), Yurk@ (18.02.2013)

Эти 2 пользователя(ей) сказали Спасибо netruxa за это полезное сообщение:
Aibekkoke (12.03.2022), gewasop (06.05.2015)