covexcel.pas

实现了在开发的数据库程序中打包加入SQL数据库驱动并允许在安装程序服务器端时安装SQL数据库 这样可以不需要实施人员或客户单独安装SQL数据库程序

unit CovExcel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, ComObj;

type

  TCovExcel = class(TComponent)
  private
    FDataSet: TDataSet;
    FTitle: string;
    FTtileFont: TFont;
    FFileName: string;
    function GetFont: TFont;
    procedure SetFont(Value: TFont);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CoverToExcel;
  published
    property DataSet: TDataSet read FDataSet write FDataSet;
    property FileName: string read FFileName write FFileName;
    property TitleFont: TFont read GetFont write SetFont;
    property Title: string read FTitle write FTitle;
  end;

procedure Register;

implementation

{ TCovExcel }

constructor TCovExcel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTtileFont := TFont.Create;
  FDataSet := nil;
end;

destructor TCovExcel.Destroy;
begin
  FTtileFont.Free;
  inherited;
end;

procedure TCovExcel.CoverToExcel;
var
  CovExcel: Variant;
  WorkBook: Variant;
  WorkSheet: Variant;
  ACol, ARow: integer;
  CuData: string;
  S: ShortString;
  Style: ShortString;
  CheckTitle: boolean;
begin
  try
    //建立OLE对象
    CovExcel := CreateOleObject('Excel.Application');
    //下面是Excel内嵌VB的代码，如果你不熟悉这些命令，可以利用Excel中
    //的【录制新的宏】命令，做你需要的操作，拷贝过来就行了。
    CovExcel.Application.EnableAutoComplete := True;
    CovExcel.Application.EnableAnimations := False;
    CovExcel.Application.ScreenUpdating := false;
    CovExcel.Application.Interactive := False;
    CovExcel.Application.DisplayAlerts := False;
    WorkBook := CovExcel.WorkBooks.Add;
    WorkSheet := WorkBook.WorkSheets[1];
    //这里的常量xlGeneral和xlBottom是在VB中定义的，Delphi中没有相应
    //定义，所以要输入数值，这些数值可以在Excel的帮助或参数中获得。
    WorkSheet.Cells.HorizontalAlignment := 1; //xlGeneral
    WorkSheet.Cells.VerticalAlignment := $FFFFEFF5; //xlBottom
    WorkSheet.Cells.WrapText := False;
    WorkSheet.Cells.Orientation := 0;
    WorkSheet.Cells.AddIndent := False;
    WorkSheet.Cells.ShrinkToFit := False;
    WorkSheet.Cells.MergeCells := False;
  except
    on Exception do
      raise exception.Create('Open Excel Error, Are you Install Excel?')
  end;

  if Assigned(DataSet) then
  begin
    with DataSet do
    begin
        //如果有标题，在Excel表的第一行建立标题
      if Title <> '' then
      begin
            //计算输出表的宽度
        S := 'A1: ' + Chr(Byte((FieldCount - 1) + 65)) + '1';
            //在Excel表中合并第一行
        WorkSheet.Range[S].Merge(True);
            //写入标题
        WorkSheet.Cells[1, 1].Value := Title;
        CheckTitle := True;
      end
      else
        CheckTitle := False;

      if CheckTitle then
        ARow := 2
      else
        ARow := 1;
      for ACol := 0 to FieldCount - 1 do
        if Fields[ACol].Visible then
         //写入字段显示名
          WorkSheet.Cells[ARow, ACol + 1].Value := Fields[ACol].DisplayLabel;
      if CheckTitle then
        ARow := 3
      else
        ARow := 2;
      First;
      while not Eof do
      begin
        for ACol := 0 to FieldCount - 1 do
          if Fields[ACol].Visible then
            //写入数据到Excel的每个单元格
            WorkSheet.Cells[ARow, ACol + 1].Value := Fields[ACol].AsString; Inc(ARow);
        Next;
      end;
      WorkSheet.Cells.Select;
      WorkSheet.Cells.EntireColumn.AutoFit;
      First;
      for ACol := 0 to FieldCount - 1 do
      begin
        if CheckTitle then
          S := Chr(byte(ACol + 65)) + '3: ' + Chr(Byte(ACol + 65)) + IntToStr(ARow - 1)
        else
          S := Chr(byte(ACol + 65)) + '2: ' + Chr(Byte(ACol + 65)) + IntToStr(ARow - 1);
        //设置Excel表的每个列的数据类型。
        if Fields[ACol].DataType in [ftDate, ftDateTime] then
          Style := 'mm / dd / yy'
        else if Fields[ACol].DataType in [ftTime] then
          Style := 'hh: mm: ss'
        else if Fields[ACol].DataType in [ftCurrency, ftBCD] then
          Style := '$#, ##0.00 '
        else if Fields[ACol].DataType in [ftInteger, ftWord, ftSmallint, ftLargeInt] then
          Style := '0_ '
        else if Fields[ACol].DataType in [ftString, ftFixedChar, ftWideString, ftMemo] then
          Style := '@';
        try
          WorkSheet.Range[S].NumberFormatLocal := Style;
        except
          CovExcel.Quit;
          CovExcel := Unassigned;
        end;
      end;
//如果有标题行，根据对TitleFont的内容，设置标题的字符属性，因为Delphi和
//Excel对Font.Style的定义不同，Delphi的Font.Style由TfontStyle定义，
//而VB的FontStyle定义使用的是字符串，所以转换非常麻烦。这里只是演示在
//Delphi中如何使用VB的命令，这段程序完全没有实用价值，可以删除，各人可
//根据自己的需要，加入自己的VB代码，来设置Excel表。
      if CheckTitle then
      begin
        S := 'A1: ' + Chr(Byte((FieldCount - 1) + 65)) + '2';
        if TitleFont.Style = [fsBold] then
          WorkSheet.Rows[1].Font.FontStyle := '加粗';
        if TitleFont.Style = [fsItalic] then
          WorkSheet.Rows[1].Font.FontStyle := '倾斜';
        if TitleFont.Style = [fsUnderline] then
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
        if TitleFont.Style = [fsStrikeOut] then
          WorkSheet.Rows[1].Font.Strikethrough := True;
        if TitleFont.Style = [fsBold, fsItalic] then
          WorkSheet.Rows[1].Font.FontStyle := '加粗 倾斜';
        if TitleFont.Style = [fsBold, fsUnderline] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
        end;
        if TitleFont.Style = [fsBold, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗';
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsItalic, fsUnderline] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '倾斜';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
        end;
        if TitleFont.Style = [fsItalic, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '倾斜';
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsBold, fsItalic, fsUnderline] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗 倾斜';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
        end;
        if TitleFont.Style = [fsBold, fsItalic, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗 倾斜';
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsBold, fsItalic, fsUnderline, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗 倾斜';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsUnderline, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsBold, fsUnderline, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '加粗';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        if TitleFont.Style = [fsItalic, fsUnderline, fsStrikeOut] then
        begin
          WorkSheet.Rows[1].Font.FontStyle := '倾斜';
          WorkSheet.Rows[1].Font.Underline := 2; //xlUnderlineStyleSingle
          WorkSheet.Rows[1].Font.Strikethrough := True;
        end;
        //设置字体大小
        WorkSheet.Rows[1].Font.Size := TitleFont.Size;
         //设置使用的字体库的名称。
        WorkSheet.Rows[1].Font.Name := TitleFont.Name;
      end
      else
        S := 'A1: ' + Chr(Byte((FieldCount - 1) + 65)) + '1';
      //将标题居中
      WorkSheet.Range[S].HorizontalAlignment := $FFFFEFF4; //xlCenter
    end;
    WorkSheet.Range['A1: A1'].Select;
//存Excel文件
    try
      WorkBook.Saveas(FileName);
    finally
      WorkBook.Close;
    end;
//退出Excel调用
    CovExcel.Quit;
    CovExcel := Unassigned;
  end;
end;

procedure TCovExcel.SetFont(Value: TFont);
begin
  FTtileFont.Assign(Value);
end;

function TCovExcel.GetFont: TFont;
begin
  Result := FTtileFont;
end;

procedure Register;
begin
  RegisterComponents('Data Controls', [TCovExcel]);
end;

end.