unit xxx;

interface

uses DB;

function  Ad_DataSetToExcel(DataSet: TDataSet; var Excel: Variant; var Sh: Variant;
    R1: Integer = 1; C1: Integer = 1; DestroyExcel: Boolean = True; AutoFit: Boolean = True; Title: Boolean = True): Integer;

implementation

uses Variants, SysUtils, ComObj, ComCtrls, Dialogs, Classes;

function  GetXLSObject(var W: Variant; SheetsN: Integer; Shablon: String; New_: Boolean = False): Boolean;
var S: String;
begin
 try
   if (ExtractFilePath(Shablon) = '') and (Shablon <> '') then
      S:=ExtractFilePath(ParamStr(0))+Shablon else S:=Shablon;
   if (S <> '') and not FileExists(S) then begin
      ShowMessage(' Файл "'+S+'" не найден.');
      Result := False;
      exit;
   end;
   if New_ then W := CreateOleObject('Excel.Application')
   else try W := GetActiveOleObject('Excel.Application'); except W := CreateOleObject('Excel.Application'); end;
   W.SheetsInNewWorkbook := 1;
   if Shablon = '' then W.Workbooks.Add
   //else W.Workbooks.Open(S, 0, True);
   else W.Workbooks.Open(S);
   W.Application.EnableEvents := false; // Отключаем реакцию Excel на события, чтобы ускорить вывод информации
   W.Sheets[SheetsN].Activate;
   Result:=True;
 except
   if W <> null then W:=UnAssigned; raise;
 end;
end;

function  ExclRange(Sheet: Variant; R1, C1, RN, CN: Integer): Variant;
var Cell1, Cell2: Variant;
begin
  Cell1 := Sheet.Cells[R1, C1]; Cell2 := Sheet.Cells[RN, CN];
  Result:= Sheet.Range[Cell1, Cell2];
end;

procedure DestroyXLSObject(var W: Variant; ViewXLS: Boolean = False);
begin
  if ViewXLS then W.Visible:=True
  else begin W.DisplayAlerts:=0; W.Workbooks.Close; end;
  W:=UnAssigned;
end;

function  Ad_DataSetToExcel(DataSet: TDataSet; var Excel: Variant; var Sh: Variant;
    R1: Integer = 1; C1: Integer = 1; DestroyExcel: Boolean = True; AutoFit: Boolean = True; Title: Boolean = True): Integer;
//----------------------------------------------------------
var
  Mas, MasF, Range: Variant;
  RecN, Cols, I, J: Integer;
begin
  Result:=0;
  try Excel.SheetsInNewWorkbook := 1;
  except
    if not GetXLSObject(Excel, 1, '') then exit;
    Sh:=Excel.Sheets[1];
  end;
  with DataSet do
   try
     DisableControls; First; RecN:=0; J:=1; Cols:=0;
     while not Eof do begin Inc(RecN); Next; end; First;
     for i := 0 to FieldCount-1 do if Fields[i].Visible then Inc(Cols);
     MasF:= VarArrayCreate([0, Cols-1], varVariant);
     Mas := VarArrayCreate([0, RecN+1, 0, Cols-1], varVariant);
     for i := 0 to FieldCount-1 do if Fields[i].Visible then MasF[i]:=Fields[i].FieldName;
     if Title then for i:=0 to Cols-1 do Mas[0,i]:=FieldByName(MasF[i]).DisplayName
     else j:=0;
     while not Eof do begin
       for i:=0 to Cols-1 do
           if Fields[i].Visible then Mas[j,i]:=FieldByName(MasF[i]).Value;
       Next; if not Eof then Inc(J);
     end;
     Range:=ExclRange(Sh, R1, C1, R1+RecN, Cols); Result:=RecN;
     //Range.WrapText:=true;    //перенос по словам
     for i:=0 to Cols-1 do
         if FieldByName(MasF[i]).DataType = ftString then
            ExclRange(Sh, R1, i+1, R1+RecN, i+1).NumberFormat:='@';

     Range.Value:=Mas;        //передача вариантного массива в Excel
     Range.Borders.Weight:=2; //сетка в Excel
     if Title then begin
        Range:=ExclRange(Sh, R1, C1, R1, Cols);
        Range.Font.Bold := True;
     end;
   finally
     MasF:=unassigned;
     Mas:=unassigned;
     if AutoFit then Sh.Cells.Columns.AutoFit;
     if DestroyExcel then DestroyXLSObject(Excel, True);
     First; EnableControls;
   end;
end;


end.