Взаимодействие с MS Office

{ **** UBPFD *********** by http://kladovka.net.ru/delphibase/ ****
>> Работа с 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.