delphi导出Excel

delphi导出EXCEL

unit Unit2;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, ADODB, Grids, DBGrids, RzDBGrid, StdCtrls, ExtCtrls;
type
  TForm2 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    RzDBGrid1: TRzDBGrid;
    ADOQuery1: TADOQuery;
    DataSource1: TDataSource;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form2: TForm2;
implementation
uses Comobj,clipbrd;
{$R *.dfm}
function   test(): boolean;
var
 aSheet  : Variant;
 excel :  Variant;
begin
try
     excel:= CreateOleObject('Excel.Application');
     showmessage('adfd');
except
     showmessage('dadafdfa');
end;
end;

function ToExcel(sfilename:string; ADOQuery:TADOQuery):boolean;
const
      xlNormal=-4143;
var
    y     :  integer;
    tsList :  TStringList;
    s,filename  :string;
    aSheet  :Variant;
    excel :OleVariant;
    savedialog  :tsavedialog;
begin
    Result := true;
    try
         excel:=CreateOleObject('Excel.Application');
         excel.workbooks.add;
      except
            //screen.cursor:=crDefault;
         showmessage('无法调用Excel！');
         exit;
    end;
    savedialog:=tsavedialog.Create(nil);
    savedialog.FileName:=sfilename;   //存入文件
    savedialog.Filter:='Excel文件(*.xls)|*.xls';
    if   savedialog.Execute   then
    begin
        if   FileExists(savedialog.FileName)   then
              try
                  if   application.messagebox('该文件已经存在，要覆盖吗？','询问',mb_yesno+mb_iconquestion)=idyes   then
                        DeleteFile(PChar(savedialog.FileName))
                  else
                  begin
                   Excel.Quit;
                   savedialog.free;
                   //screen.cursor:=crDefault;
                   Exit;
                  end;
              except
                  Excel.Quit;
                  savedialog.free;
                  screen.cursor:=crDefault;
                  Exit;
              end;
        filename:=savedialog.FileName;
    end;
    savedialog.free;
    if   filename=''   then
    begin
      result:=true;
      Excel.Quit;
      //screen.cursor:=crDefault;
      exit;
    end;
    aSheet:=excel.Worksheets.Item[1];
    tsList:=TStringList.Create;
    //tsList.Add('查询结果');   //加入标题
    s:='';   //加入字段名
    for y := 0 to adoquery.fieldCount - 1 do
    begin
       s:=s+adoQuery.Fields.Fields[y].FieldName+#9 ;
       Application.ProcessMessages;
    end;
    tsList.Add(s);
    try
        try
            ADOQuery.First;
            While Not ADOQuery.Eof do
            begin
                s:='';
                for y:=0 to ADOQuery.FieldCount-1 do
                begin
                    s:=s+ADOQuery.Fields[y].AsString+#9;
                    Application.ProcessMessages;
                end;
                tsList.Add(s);
                ADOQuery.next;
            end;
            Clipboard.AsText:=tsList.Text;
        except
            result:=false;
        end;
    finally
        tsList.Free;
    end;
    aSheet.Paste;
    MessageBox(Application.Handle,'数据导出完毕！','系统提示',MB_ICONINFORMATION or MB_OK);
    try
          if   copy(FileName,length(FileName)-3,4)<>'.xls'   then
                FileName:=FileName+'.xls';
          Excel.ActiveWorkbook.SaveAs(FileName,   xlNormal,   '',   '',   False,   False);
    except
      Excel.Quit;
      screen.cursor:=crDefault;
      exit;
    end;
    Excel.Visible   :=   false; //true会自动打开已经保存的excel
    Excel.Quit;
    Excel := UnAssigned;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
       ToExcel('D:\a.xsl',ADOQuery1);
end;
end.