{ **** UBPFD *********** by kladovka.net.ru ****
>>
На данный момент работает:
- вызов и закрытие Excel
- добавление новых, открытие ранее созданных и удаление рабочих книг
- добавление и удаление листов в рабочие книги
Зависимости: ComObj, SysUtils,Dialogs,Controls;
Автор: lookin, <a href="mailto:lookin@mail.ru">lookin@mail.ru</a>, Екатеринбург
Copyright: lookin
Дата: 04 мая 2002 г.
********************************************** }
unit MSExcel;
interface
uses ComObj, SysUtils,Dialogs,Controls;
 procedure CallExcel(Show: boolean);
 procedure CloseExcel;
 procedure AddWorkBook(WorkBookName: Ansistring);
 procedure OpenWorkBook(WorkBookName: Ansistring);
 procedure CloseWorkBook(WorkBookName: Ansistring);
 procedure ActivateWorkBook(WorkBookName: Ansistring);
 procedure ActivateWorkSheet(WorkBookName,WorkSheetName: Ansistring);
 function WorkBookIndex(WorkBookName: Ansistring): integer;
 function WorkSheetIndex(WorkBookName,WorkSheetName: Ansistring): integer;
 procedure CheckExtension(Name: Ansistring);
 procedure AddWorkSheet(WorkBookName,WorkSheetName: Ansistring);
 procedure DeleteWorkSheet(WorkBookName,WorkSheetName: Ansistring);
var Excel: Variant;
implementation

procedure CallExcel(Show: boolean);
begin
 if VarIsEmpty(Excel)=true then begin
 Excel:=CreateOleObject('Excel.Application');
 if Show then Excel.Visible:=true; end;
end;
procedure CloseExcel;
begin
 if VarIsEmpty(Excel)=false then begin
 Excel.Quit; Excel:=0; end;
end;
procedure AddWorkBook(WorkBookName: Ansistring);
var k: integer;
begin
 CheckExtension(WorkBookName);
 if VarIsEmpty(Excel)=true then begin
 Excel:=CreateOleObject('Excel.Application'); Excel.Visible:=true; end;
 k:=WorkBookIndex(WorkBookName);
 if k=0 then begin Excel.Workbooks.Add;
 Excel.ActiveWorkbook.SaveCopyAs(FileName:=WorkBookName);
 Excel.ActiveWorkbook.Close;
 Excel.Workbooks.Open(WorkBookName); end else
 MessageDlg('Книга с таким именем уже существует.',mtWarning,[mbOk],0);
end;
procedure OpenWorkBook(WorkBookName: Ansistring);
var k: integer;
begin
 CheckExtension(WorkBookName);
 if VarIsEmpty(Excel)=true then begin
 Excel:=CreateOleObject('Excel.Application'); Excel.Visible:=true; end;
 k:=WorkBookIndex(WorkBookName);
 if k=0 then Excel.Workbooks.Open(WorkBookName) else
 MessageDlg('Книга с таким именем уже открыта.',mtWarning,[mbOk],0);
end;
procedure CloseWorkBook(WorkBookName: Ansistring);
var k: integer;
begin
 if VarIsEmpty(Excel)=false then begin
 k:=WorkBookIndex(WorkBookName);
 if k<>0 then Excel.ActiveWorkbook.Close(WorkBookName) else
 MessageDlg('Книга с таким именем отсутствует.',mtWarning,[mbOk],0); end;
end;
procedure ActivateWorkBook(WorkBookName: Ansistring);
var k: integer;
begin
 if VarIsEmpty(Excel)=false then begin
 k:=WorkBookIndex(WorkBookName);
 if k<>0 then Excel.WorkBooks[k].Activate; end;
end;
procedure ActivateWorkSheet(WorkBookName,WorkSheetName: Ansistring);
var k,j: integer;
begin
 if VarIsEmpty(Excel)=false then begin
 k:=WorkBookIndex(WorkBookName);
 j:=WorkSheetIndex(WorkBookName,WorkSheetName);
 if j<>0 then Excel.WorkBooks[k].Sheets[j].Activate; end;
end;
procedure AddWorkSheet(WorkBookName,WorkSheetName: Ansistring);
var k,j: integer;
begin
 if VarIsEmpty(Excel)=false then begin
 k:=WorkBookIndex(WorkBookName);
 if k<>0 then begin Excel.DisplayAlerts:=False;
 Excel.Workbooks[k].Sheets.Add;
 j:=WorkSheetIndex(WorkBookName,WorkSheetName);
 if j=0 then Excel.Workbooks[k].ActiveSheet.Name:=WorkSheetName;
 end; end;
end;
procedure DeleteWorkSheet(WorkBookName,WorkSheetName: Ansistring);
var k,j: integer;
begin
 if VarIsEmpty(Excel)=false then begin k:=WorkBookIndex(WorkBookName);
 Excel.DisplayAlerts:=false;
 j:=WorkSheetIndex(WorkBookName,WorkSheetName);
 if j<>0 then Excel.Workbooks[k].Sheets[j].Delete else
 MessageDlg('Листа с таким именем в этой книге нет.',mtWarning,[mbOk],0); end;
end;
procedure CheckExtension(Name: Ansistring);
var s: string;
begin
//проверка расширения
 s:=ExtractFileExt(Name);
 if LowerCase(s)<>'.xls' then
 if MessageDlg('Вы задали имя книги с нестандартным расширением. Продолжить?',
 mtWarning,[mbYes,mbCancel],0)=mrCancel then Abort;
end;
function WorkBookIndex(WorkBookName: Ansistring): integer;
var i,n: integer;
begin
//проверка на наличие книги с этим именем
 n:=0;
 if VarIsEmpty(Excel)=false then for i:=1 to Excel.WorkBooks.Count do
 if Excel.WorkBooks[i].FullName=WorkBookName then begin n:=i; break; end;
 WorkBookIndex:=n;
end;
function WorkSheetIndex(WorkBookName,WorkSheetName: Ansistring): integer;
var i,k,n: integer;
begin
//проверка на наличие листа с этим именем в книге с этим именем
 n:=0;
 if VarIsEmpty(Excel)=false then begin k:=WorkBookIndex(WorkBookName);
 for i:=1 to Excel.WorkBooks[k].Sheets.Count do
 if Excel.WorkBooks[k].Sheets[i].Name=WorkSheetName then begin
 n:=i; break; end; end; WorkSheetIndex:=n;
end;
end.

procedure TForm1.Button1Click(Sender: TObject);

begin

//вызов Excel, true - если хотите при вызове Excel отобразить окно Excel

 CallExcel(true);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

//добавление новой рабочей книги с заданным именем

//ВАЖНО: используйте полное имя рабочей книги, т.е. включая путь

 AddWorkBook('D:\qwerty.xls');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

//добавление листа с именем ff в рабочую книгу D:\qwerty.xls

 AddWorksheet('D:\qwerty.xls','ff');

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

//активация рабочей книги

 ActivateWorkBook('D:\1234.xls');

end;

procedure TForm1.Button5Click(Sender: TObject);

begin

//активация листа в рабочей книге

 ActivateWorkSheet('D:\qwerty.xls','ff');

end;

procedure TForm1.Button6Click(Sender: TObject);

begin

//открытие рабочей книги

 OpenWorkBook('D:\qwerty.xls');

end;

procedure TForm1.Button7Click(Sender: TObject);

begin

//закрытие рабочей книги

 CloseWorkBook('D:\qwerty.xls');

end;

procedure TForm1.Button8Click(Sender: TObject);

begin

//удаление листа из рабочей книги

 DeleteWorkSheet('D:\qwerty.xls','ff');

end;

procedure TForm1.Button9Click(Sender: TObject);

begin

//закрытие Excel

 CloseExcel;

end;

end.