Delphi 控制Excel（3）

根据别人的组件改写的支持ADO

unit AdoToOleExcel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,Controls, Forms, Dialogs,
  comobj, DBTables, Grids,ADODB;
type
  TAdoToOleExcel = 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 AdoTable: TAdoTable; var Cell:Variant);
    procedureGetQueryColumnName(const AdoQuery: TAdoQuery; 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;
    procedureADOTableToExcel(const ADOTable: TADOTable);
    procedureADOQueryToExcel(const ADOQuery: TADOQuery);
    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 TAdoToOleExcel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIgnoreFont := True;
  FCellFont := TFont.Create;
  FTitleFont := TFont.Create;
  FExcelCreated := False;
  FVisible := False;
  FFontChanged := False;
end;

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

procedure TAdoToOleExcel.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 TAdoToOleExcel.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 TAdoToOleExcel.SetVisible(DoShow: Boolean);
begin
  if not FExcelCreated then exit;
  if DoShow then
   FExcel.Visible := True
  else
   FExcel.Visible := False;
end;

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

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

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

procedure TAdoToOleExcel.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 TAdoToOleExcel.CreateExcelInstance;
begin
  try
    FExcel :=CreateOLEObject('Excel.Application');
    FWorkBook :=FExcel.WorkBooks.Add;
    FWorkSheet:= FWorkBook.WorkSheets.Add;
   FExcelCreated := True;
  except
   FExcelCreated := False;
  end;
end;

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

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

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

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

procedure TAdoToOleExcel.ADOTableToExcel(const ADOTable:TADOTable);
var
  Col, Row: LongInt;
  Cell: Variant;
begin
  if not FExcelCreated then exit;
  if ADOTable.Active = False then exit;

  GetTableColumnName(ADOTable, Cell);
  Row := 2;
  with ADOTable 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 TAdoToOleExcel.GetQueryColumnName(const ADOQuery:TADOQuery; var Cell: Variant);
var
  Col: integer;
begin
  for Col := 0 to ADOQuery.FieldCount - 1 do
    begin
     Cell := FWorkSheet.Cells[1, Col + 1];
     SetExcelTitleFont(Cell);
     Cell.Value := ADOQuery.Fields[Col].FieldName;
    end;
end;

procedure TAdoToOleExcel.ADOQueryToExcel(const ADOQuery:TADOQuery);
var
  Col, Row: LongInt;
  Cell: Variant;
begin
  if not FExcelCreated then exit;
  if ADOQuery.Active = False then exit;

  GetQueryColumnName(ADOQuery, Cell);
  Row := 2;
  with ADOQuery 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 TAdoToOleExcel.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 TAdoToOleExcel.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 TAdoToOleExcel.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 TAdoToOleExcel.StringGridToExcel(const StringGrid:TStringGrid);
var
  Cell: Variant;
begin
  if not FExcelCreated then exit;
  GetFixedCols(StringGrid, Cell);
  GetFixedRows(StringGrid, Cell);
  GetStringGridBody(StringGrid, Cell);
end;

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

procedure Register;
begin
  RegisterComponents('Freeman',[TAdoToOleExcel]);
end;

end.