Автор: Daun
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Работа с MS Excel

Основная функция - передача данных из DataSet в Excel

Зависимости: ComObj, QDialogs, SysUtils, Variants, DB
Автор:       Daun, daun@mail.kz
Copyright:   daun
Дата:        5 октября 2002 г.
***************************************************** }

unit ExcelModule;

interface

uses ComObj, QDialogs, SysUtils, Variants, DB;

//**=====================================================
//** MS Excel
//**=====================================================

//** Открытие Excel
procedure ExcelCreateApplication(FirstSheetName: string; //назв-е 1ого листа
  SheetCount: Integer; //кол-во листов
  ExcelVisible: Boolean); //отображение книги

//** Перевод номера столбца в букву, напр. 1='A',2='B',..,28='AB'
//** Должно работать до 'ZZ'
function ExcelChar(Num: Integer): string;

//** Оформление указанного диапазона бордерами
procedure ExcelRangeBorders(RangeBorders: Variant; //диапазон
  BOutSideSize: Byte; //толщина снаружи
  BInsideSize: Byte; //толщина внутри
  BOutSideVerticalLeft: Boolean;
  BOutSideVerticalRight: Boolean;
  BInSideVertical: Boolean;
  BOutSideHorizUp: Boolean;
  BOutSideHorizDown: Boolean;
  BInSideHoriz: Boolean);

//** Форматирование диапазона (шрифт, размер)
procedure ExcelFormatRange(RangeFormat: Variant;
  Font: string;
  Size: Byte;
  AutoFit: Boolean);
//** Вывод DataSet
procedure ExcelGetDataSet(DataSet: TDataSet;
  SheetNumber: Integer; // Номер листа
  FirstRow: Integer; // Первая строка
  FirstCol: Integer; // Первый столбец
  ShowCaptions: Boolean; // Вывод заголовков DataSet
  ShowNumbers: Boolean; // Вывод номеров (N пп)
  FirstNumber: Integer; // Первый номер
  ShowBorders: Boolean; // Вывод бордюра
  StepCol: Byte; // Шаг колонок: 0-подряд,
  // 1-через одну и тд
  StepRow: Byte); // Шаг строк

//** Меняет имя листа
procedure ExcelSetSheetName(SheetNumber: Byte; //номер листа
  SheetName: string); //имя
//** Делает Excel видимым
procedure ExcelShow;

//** Сохранение книги
procedure ExcelSaveWorkBook(Name: string);

//**=====================================================
//** MS Word
//**=====================================================

//** Открытие Ворда
procedure CreateWordAppl(WordVisible: Boolean);

//** Отображение Ворда
procedure MakeWordVisible;

//** Набор текста
procedure WordTypeText(s: string);

//** Новый параграф
procedure NewParag(Bold: Boolean;
  Italic: Boolean;
  ULine: Boolean;
  Alignment: Integer;
  FontSize: Integer);

var
  Excel, Sheet, Range, Columns: Variant;

  MSWord, Selection: Variant;

implementation

procedure ExcelCreateApplication(FirstSheetName: string;
  SheetCount: Integer;
  ExcelVisible: Boolean);
begin
  try
    Excel := CreateOleObject('Excel.Application');
    Excel.Application.EnableEvents := False;
    Excel.DisplayAlerts := False;
    Excel.SheetsInNewWorkbook := SheetCount;
    Excel.Visible := ExcelVisible;
    Excel.WorkBooks.Add;
    Sheet := Excel.WorkBooks[1].Sheets[1];
    Sheet.Name := FirstSheetName;
  except
    Exception.Create('Error.');
    Excel := UnAssigned;
  end;
end;

function ExcelChar(Num: Integer): string;
var
  S: string;
  I: Integer;
begin
  I := Trunc(Num / 26);
  if Num > 26 then
    S := Chr(I + 64) + Chr(Num - (I * 26) + 64)
  else
    S := Chr(Num + 64);
  Result := S;
end;

procedure ExcelRangeBorders(RangeBorders: Variant;
  BOutSideSize: Byte;
  BInsideSize: Byte;
  BOutSideVerticalLeft: Boolean;
  BOutSideVerticalRight: Boolean;
  BInSideVertical: Boolean;
  BOutSideHorizUp: Boolean;
  BOutSideHorizDown: Boolean;
  BInSideHoriz: Boolean);
begin
  if BOutSideVerticalLeft then
  begin
    RangeBorders.Borders[7].LineStyle := 1;
    RangeBorders.Borders[7].Weight := BOutSideSize;
    RangeBorders.Borders[7].ColorIndex := -4105;
  end;
  if BOutSideHorizUp then
  begin
    RangeBorders.Borders[8].LineStyle := 1;
    RangeBorders.Borders[8].Weight := BOutSideSize;
    RangeBorders.Borders[8].ColorIndex := -4105;
  end;
  if BOutSideHorizDown then
  begin
    RangeBorders.Borders[9].LineStyle := 1;
    RangeBorders.Borders[9].Weight := BOutSideSize;
    RangeBorders.Borders[9].ColorIndex := -4105;
  end;
  if BOutSideVerticalRight then
  begin
    RangeBorders.Borders[10].LineStyle := 1;
    RangeBorders.Borders[10].Weight := BOutSideSize;
    RangeBorders.Borders[10].ColorIndex := -4105;
  end;
  if BInSideVertical then
  begin
    RangeBorders.Borders[11].LineStyle := 1;
    RangeBorders.Borders[11].Weight := BInSideSize;
    RangeBorders.Borders[11].ColorIndex := -4105;
  end;
  if BInsideHoriz then
  begin
    RangeBorders.Borders[12].LineStyle := 1;
    RangeBorders.Borders[12].Weight := BInSideSize;
    RangeBorders.Borders[12].ColorIndex := -4105;
  end;
end;

procedure ExcelFormatRange(RangeFormat: Variant;
  Font: string;
  Size: Byte;
  AutoFit: Boolean);
begin
  RangeFormat.Font.Name := 'Arial';
  RangeFormat.Font.Size := 7;
  if AutoFit then
    RangeFormat.Columns.AutoFit;
end;

procedure ExcelSetSheetName(SheetNumber: Byte;
  SheetName: string);
begin
  try
    Sheet := Excel.WorkBooks[1].Sheets[SheetNumber];
    Sheet.Name := SheetName;
  except
    Exception.Create('Error.');
    Exit;
  end;
end;

procedure ExcelShow;
begin
  Excel.Visible := True;
  Excel := UnAssigned;
end;

procedure ExcelGetDataSet(DataSet: TDataSet;
  SheetNumber: Integer;
  FirstRow: Integer;
  FirstCol: Integer;
  ShowCaptions: Boolean;
  ShowNumbers: Boolean;
  FirstNumber: Integer;
  ShowBorders: Boolean;
  StepCol: Byte;
  StepRow: Byte);
var
  Column: Integer;
  Row: Integer;
  I: Integer;
begin
  if (ShowCaptions) and (FirstRow < 2) then
    FirstRow := 2;
  if (ShowNumbers) and (FirstCol < 2) then
    FirstCol := 2;

  try
    Sheet := Excel.WorkBooks[1].Sheets[SheetNumber];
  except
    Exception.Create('Error.');
    Exit;
  end;

  try
    with DataSet do
    try
      DisableControls;

      if ShowCaptions then
      begin
        Row := FirstRow - 1;
        Column := FirstCol;
        for i := 0 to FieldCount - 1 do
          if Fields[i].Visible then
          begin
            Sheet.Cells[Row, Column] := Fields[i].DisplayName;
            Inc(Column);
          end;
        Sheet.Rows[Row].Font.Bold := True;
      end;

      Row := FirstRow;
      First;
      while not EOF do
      begin
        Column := FirstCol;
        if ShowNumbers then
          Sheet.Cells[Row, FirstCol - 1] := FirstNumber;

        for i := 0 to FieldCount - 1 do
        begin
          if Fields[i].Visible then
          begin
            if Fields[i].DataType <> ftfloat then
              Sheet.Cells[Row, Column] := Trim(Fields[i].DisplayText)
            else
              Sheet.Cells[Row, Column] := Fields[i].Value;
            Inc(Column, StepCol);
          end;
        end;
        Inc(Row, StepRow);
        Inc(FirstNumber);
        Next;
      end;

      if ShowBorders then
      begin
        if ShowCaptions then
          Dec(FirstRow);
        if ShowNumbers then
          FirstCol := FirstCol - 1;
        Range := Sheet.Range[ExcelChar(FirstCol) + IntToStr(FirstRow) +
          ':' + ExcelChar(Column - 1) + IntToStr(Row - 1)];
        if (Row - FirstRow) < 2 then
          ExcelRangeBorders(Range, 3, 2, True, True,
            True, True, True, False)
        else
          ExcelRangeBorders(Range, 3, 2, True, True,
            True, True, True, True);
        ExcelFormatRange(Range, 'Arial', 7, True);
      end;

    finally
      EnableControls;
    end;
  finally
  end;
end;

procedure ExcelSaveWorkBook(Name: string);
begin
  Excel.ActiveWorkbook.SaveAs(Name);
end;

procedure CreateWordAppl(WordVisible: Boolean);
begin
  try
    MsWord := GetActiveOleObject('Word.Application');
    MSWord.Documents.Add;
  except
    try
      MsWord := CreateOleObject('Word.Application');
      MsWord.Visible := WordVisible;
      MSWord.Documents.Add;
    except
      Exception.Create('Error.');
      MSWord := Unassigned;
    end;
  end;
end;

procedure MakeWordVisible;
begin
  MsWord.Visible := True;
  MSWord := Unassigned;
end;

procedure WordTypeText(S: string);
begin
  MSWord.Selection.TypeText(S);
end;

procedure NewParag(Bold: Boolean;
  Italic: Boolean;
  ULine: Boolean;
  Alignment: Integer;
  FontSize: Integer);
begin
  MsWord.Selection.TypeParagraph;
  MSWord.Selection.ParagraphFormat.Alignment := Alignment;
  MSWord.Selection.Font.Bold := Bold;
  MSWord.Selection.Font.Italic := Italic;
  MSWord.Selection.Font.UnderLine := ULine;
  MSWord.Selection.Font.Size := FontSize;
end;

end.

// Пример использования:

unit Example;
...
uses..., ExcelModule;
...

procedure Tform1.Button1.Click(Sender: TObject);
begin
  Query1.SQL.Text := 'select * from Table';
  Query1.Open;
  ExcelCreateApplication('Example', 1, True);
  ExcelGetDataSet(Query1, 1, 1, 1, True, True, 1, True, 1, 1);
  ExcelShow;
end;
...
end.