盒子论坛 v2.1

将数据库的表或查询转换成Excel，
一个用于将数据库的表转换成Excel表的组件。安装后即可使用。但组件的功能有限，可根据需要加入相应的代码。
运行条件：计算机上必须安装Excel。
运行环境：Delphi 5。

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.

下面是如何使用这个组件的代码：
procedure TForm1.Button1Click(Sender: TObject);
begin
  if not ADOTable1.Active then
    ADOTable1.Active := True;
  ADOTable1.First;
  CovExcel1.FileName := 'C:\Temp\MyExcel.xls';
  CovExcel1.DataSet := ADOTable1;
  CoveExcel1.Title := 'MyExcel';
  CovExcel1.CoverToExcel;
end;

另外，在Delphi中不能打开Debugger调试OLE调用。

----------------------------------------------
ask not what your country can do for you--ask what you can do for your country.

信息

登陆以后才能回复