Delphi 控制Excel（2）

最新推荐文章于 2021-09-04 17:43:27 发布

robin844

最新推荐文章于 2021-09-04 17:43:27 发布

阅读量834

点赞数

分类专栏： Excel

Excel 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

看看我的函数
function ExportToExcel(Header: String;

vDataSet: TDataSet): Boolean;
var
I,VL_I,j: integer;
S,SysPath: string;
MsExcel:Variant;
begin
Result:=true;
ifApplication.MessageBox('您确信将数据导入到Excel吗?','提示！',MB_OKCANCEL +MB_DEFBUTTON1) = IDOK then
begin
SysPath:=ExtractFilePath(application.exename);
with TStringList.Create do
try
vDataSet.First ;
S:=S+Header;
// system.Delete(s,1,1);
add(s);
s:=';
For I:=0 to vDataSet.fieldcount-1 do
begin
If vDataSet.fields[I].visible=true then
S:=S+#9+vDataSet.fields[I].displaylabel;
end;
system.Delete(s,1,1);
add(s);
while not vDataSet.Eof do
begin
S := ';
for I := 0 to vDataSet.FieldCount -1 do
begin
If vDataSet.fields[I].visible=true then
S := S + #9 + vDataSet.Fields[I].AsString;
end;
System.Delete(S, 1, 1);
Add(S);
vDataSet.Next;
end;
Try
SaveToFile(SysPath+'\Tem.xls');
Except
ShowMessage('写文件时发生保护性错误，Excel 如在运行，请先关闭！');
Result:=false;
exit;
end;
finally
Free;
end;
Try
MSExcel:=CreateOleObject('Excel.Application');
Except
ShowMessage('Excel 没有安装，请先安装！');
Result:=false;
exit;
end;
Try
MSExcel.workbooks.open(SysPath+'\Tem.xls');
Except
ShowMessage('打开临时文件时出错，请检查'+SysPath+'\Tem.xls');
Result:=false;
exit;
end;
MSExcel.visible:=True;
for VL_I :=1 to 4 do
MSExcel.Selection.Borders[VL_I].LineStyle := 0;
MSExcel.cells.select;
MSExcel.Selection.HorizontalAlignment :=3;
MSExcel.Selection.Borders[1].LineStyle := 0;

MSExcel.Range['A1'].Select;
MSExcel.Selection.Font.Size :=24;

     J:=0 ;
     for i:=0 to vdataset.fieldcount-1 do
         if vDataSet.fields[I].visible then
            J:=J+1;

     VL_I :=J;
     MSExcel.Range['A1:'+F_ColumnName(VL_I)+'1'].Select;
     MSExcel.Range['A1:'+F_ColumnName(VL_I)+'1'].Merge;
end
else
   Result:=false;
end;

转别人的组件
unit OleExcel;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,Controls, Forms, Dialogs,
comobj, DBTables, Grids;
type
TOLEExcel = class(TComponent)
private
   FExcelCreated: Boolean;
    FVisible:Boolean;
    FExcel:Variant;
    FWorkBook:Variant;
    FWorkSheet:Variant;
    FCellFont:TFont;
    FTitleFont:TFont;
   FFontChanged: Boolean;
    FIgnoreFont:Boolean;
    FFileName:TFileName;
    procedureSetExcelCellFont(var Cell: Variant);
    procedureSetExcelTitleFont(var Cell: Variant);
    procedureGetTableColumnName(const Table: TTable; var Cell: Variant);
    procedureGetQueryColumnName(const Query: TQuery; var Cell: Variant);
    procedureGetFixedCols(const StringGrid: TStringGrid; var Cell:Variant);
    procedureGetFixedRows(const StringGrid: TStringGrid; var Cell:Variant);
    procedureGetStringGridBody(const StringGrid: TStringGrid; var Cell:Variant);
protected
    procedureSetCellFont(NewFont: TFont);
    procedureSetTitleFont(NewFont: TFont);
    procedureSetVisible(DoShow: Boolean);
    functionGetCell(ACol, ARow: Integer): string;
    procedureSetCell(ACol, ARow: Integer; const Value: string);

    functionGetDateCell(ACol, ARow: Integer): TDateTime;
    procedureSetDateCell(ACol, ARow: Integer; const Value: TDateTime);
public
    constructorCreate(AOwner: TComponent); override;
    destructorDestroy; override;
    procedureCreateExcelInstance;
    propertyCell[ACol, ARow: Integer]: string read GetCell write SetCell;
    propertyDateCell[ACol, ARow: Integer]: TDateTime read GetDateCell writeSetDateCell;
    functionIsCreated: Boolean;
    procedureTableToExcel(const Table: TTable);
    procedureQueryToExcel(const Query: TQuery);
    procedureStringGridToExcel(const StringGrid: TStringGrid);
    procedureSaveToExcel(const FileName: string);
published
    propertyTitleFont: TFont read FTitleFont write SetTitleFont;
    propertyCellFont: TFont read FCellFont write SetCellFont;
    propertyVisible: Boolean read FVisible write SetVisible;
    propertyIgnoreFont: Boolean read FIgnoreFont write FIgnoreFont;
    propertyFileName: TFileName read FFileName write FFileName;
end;

procedure Register;

implementation

constructor TOLEExcel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FIgnoreFont := True;
FCellFont := TFont.Create;
FTitleFont := TFont.Create;
FExcelCreated := False;
FVisible := False;
FFontChanged := False;
end;

destructor TOLEExcel.Destroy;
begin
FCellFont.Free;
FTitleFont.Free;
inherited Destroy;
end;

procedure TOLEExcel.SetExcelCellFont(var Cell: Variant);
begin
if FIgnoreFont then exit;
with FCellFont do
    begin
     Cell.Font.Name := Name;
     Cell.Font.Size := Size;
     Cell.Font.Color := Color;
     Cell.Font.Bold := fsBold in Style;
     Cell.Font.Italic := fsItalic in Style;
     Cell.Font.UnderLine := fsUnderline in Style;
     Cell.Font.Strikethrough := fsStrikeout in Style;
    end;
end;

procedure TOLEExcel.SetExcelTitleFont(var Cell: Variant);
begin
if FIgnoreFont then exit;
with FTitleFont do
    begin
     Cell.Font.Name := Name;
     Cell.Font.Size := Size;
     Cell.Font.Color := Color;
     Cell.Font.Bold := fsBold in Style;
     Cell.Font.Italic := fsItalic in Style;
     Cell.Font.UnderLine := fsUnderline in Style;
     Cell.Font.Strikethrough := fsStrikeout in Style;
    end;
end;

procedure TOLEExcel.SetVisible(DoShow: Boolean);
begin
if not FExcelCreated then exit;
if DoShow then
FExcel.Visible := True
else
FExcel.Visible := False;
end;

function TOLEExcel.GetCell(ACol, ARow: Integer): string;
begin
if not FExcelCreated then exit;
result := FWorkSheet.Cells[ARow, ACol];
end;

procedure TOLEExcel.SetCell(ACol, ARow: Integer; const Value:string);
var
Cell: Variant;
begin
if not FExcelCreated then exit;
Cell := FWorkSheet.Cells[ARow, ACol];
SetExcelCellFont(Cell);
Cell.Value := Value;
end;

function TOLEExcel.GetDateCell(ACol, ARow: Integer):TDateTime;
begin
if not FExcelCreated then
    begin
     result := 0;
     exit;
    end;
result := StrToDateTime(FWorkSheet.Cells[ARow,ACol]);
end;

procedure TOLEExcel.SetDateCell(ACol, ARow: Integer; constValue: TDateTime);
var
Cell: Variant;
begin
if not FExcelCreated then exit;
Cell := FWorkSheet.Cells[ARow, ACol];
SetExcelCellFont(Cell);
Cell.Value := '' + DateTimeToStr(Value);
end;

procedure TOLEExcel.CreateExcelInstance;
begin
try
    FExcel :=CreateOLEObject('Excel.Application');
    FWorkBook :=FExcel.WorkBooks.Add;
    FWorkSheet:= FWorkBook.WorkSheets.Add;
   FExcelCreated := True;
except
   FExcelCreated := False;
end;
end;

function TOLEExcel.IsCreated: Boolean;
begin
result := FExcelCreated;
end;

procedure TOLEExcel.SetTitleFont(NewFont: TFont);
begin
if NewFont <>FTitleFont then
FTitleFont.Assign(NewFont);
end;

procedure TOLEExcel.SetCellFont(NewFont: TFont);
begin
if NewFont <>FCellFont then
FCellFont.Assign(NewFont);
end;

procedure TOLEExcel.GetTableColumnName(const Table: TTable; varCell: Variant);
var
Col: integer;
begin
for Col := 0 to Table.FieldCount - 1 do
    begin
     Cell := FWorkSheet.Cells[1, Col + 1];
     SetExcelTitleFont(Cell);
     Cell.Value := Table.Fields[Col].FieldName;
    end;
end;

procedure TOLEExcel.TableToExcel(const Table: TTable);
var
Col, Row: LongInt;
Cell: Variant;
begin
if not FExcelCreated then exit;
if Table.Active = False then exit;

GetTableColumnName(Table, Cell);
Row := 2;
with Table do
    begin
     first;
     while not EOF do
       begin
         for Col := 0 to FieldCount - 1 do
           begin
             Cell := FWorkSheet.Cells[Row, Col + 1];
             SetExcelCellFont(Cell);
             Cell.Value := Fields[Col].AsString;
           end;
         next;
         Inc(Row);
       end;
    end;
end;

procedure TOLEExcel.GetQueryColumnName(const Query: TQuery; varCell: Variant);
var
Col: integer;
begin
for Col := 0 to Query.FieldCount - 1 do
    begin
     Cell := FWorkSheet.Cells[1, Col + 1];
     SetExcelTitleFont(Cell);
     Cell.Value := Query.Fields[Col].FieldName;
    end;
end;

procedure TOLEExcel.QueryToExcel(const Query: TQuery);
var
Col, Row: LongInt;
Cell: Variant;
begin
if not FExcelCreated then exit;
if Query.Active = False then exit;

GetQueryColumnName(Query, Cell);
Row := 2;
with Query do
    begin
     first;
     while not EOF do
       begin
         for Col := 0 to FieldCount - 1 do
           begin
             Cell := FWorkSheet.Cells[Row, Col + 1];
             SetExcelCellFont(Cell);
             Cell.Value := Fields[Col].AsString;
           end;
         next;
         Inc(Row);
       end;
    end;
end;

procedure TOLEExcel.GetFixedCols(const StringGrid: TStringGrid;var Cell: Variant);
var
Col, Row: LongInt;
begin
for Col := 0 to StringGrid.FixedCols - 1do
    for Row := 0to StringGrid.RowCount - 1 do
     begin
       Cell := FWorkSheet.Cells[Row + 1, Col + 1];
       SetExcelTitleFont(Cell);
       Cell.Value := StringGrid.Cells[Col, Row];
     end;
end;

procedure TOLEExcel.GetFixedRows(const StringGrid: TStringGrid;var Cell: Variant);
var
Col, Row: LongInt;
begin
for Row := 0 to StringGrid.FixedRows - 1do
    for Col := 0to StringGrid.ColCount - 1 do
     begin
       Cell := FWorkSheet.Cells[Row + 1, Col + 1];
       SetExcelTitleFont(Cell);
       Cell.Value := StringGrid.Cells[Col, Row];
     end;
end;

procedure TOLEExcel.GetStringGridBody(const StringGrid:TStringGrid; var Cell: Variant);
var
Col, Row, x, y: LongInt;
begin
Col := StringGrid.FixedCols;
Row := StringGrid.FixedRows;
for x := Row to StringGrid.RowCount - 1 do
    for y := Colto StringGrid.ColCount - 1 do
     begin
       Cell := FWorkSheet.Cells[x + 1, y + 1];
       SetExcelCellFont(Cell);
       Cell.Value := StringGrid.Cells[y, x];
     end;
end;

procedure TOLEExcel.StringGridToExcel(const StringGrid:TStringGrid);
var
Cell: Variant;
begin
if not FExcelCreated then exit;
GetFixedCols(StringGrid, Cell);
GetFixedRows(StringGrid, Cell);
GetStringGridBody(StringGrid, Cell);
end;

procedure TOLEExcel.SaveToExcel(const FileName: string);
begin
if not FExcelCreated then exit;
FWorkSheet.SaveAs(FileName);
end;

procedure Register;
begin
RegisterComponents('Tanglu', [TOLEExcel]);
end;

end.
----------------------------------------------