Работа с MSExcel



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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Работа с MS Excel
Основная функция - передача данных из DataSet в Excel
Зависимости: ComObj, QDialogs, SysUtils, Variants, DB
Автор:       Daun, [email protected]
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.

Далее: Работа с MsWord из Delphi - Нестандартные отчёты »»