数据库的一个表导出到Excel,如何将这段代码转换成Delphi代码

Question

以下是我用VB导出到EXCEL的全部代码,使用了两个函数,第一个函数将会调用到第二个函数
在VB6下运行通过,如何转变成Delphi代码
'引用Microsoft Excel 9.0 Object Library （9.0为版本号）,在VB6中菜单点击"工程"再选"引用"即可,如果Delphi要这我不会,请指教'第一个函数:
Public Function ExporToExcel(strOpen As String, ExcelVisable As Boolean)
'**************************************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel sql查询字符串,True/False是否显示Excel
'**************************************************************************
    Dim strfilename1
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer
    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    
    Screen.MousePointer = vbHourglass '鼠标图形变为时钟
    
    '首先以一个记录集Rs_Data连接打开一个表
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = conn ' conn为 ADODB.Connection对象
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    
   '取得这个表的记录总数和记录字段总数
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlSheet.Name = "表1"  '指定表名
    'xlApp.Visible = True
    'xlApp.Visible = False
    
    '把表记录集赋给EXCEL
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1")) '从a1这个格子开始写入
    
    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
      '以下用到的属设置不需循环语句
    With xlSheet
        
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).NumberFormatLocal = "@"
        '格式化为文本型
        
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    
    End With
        
    '设置页眉和页脚
    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："
        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
    End WithScreen.MousePointer = vbArrow '恢复鼠标原来的图形'------------------下面是显示EXCEL与不显示EXCEL作保存的处理---------------If ExcelVisable = True Then '显示EXCEL
    xlApp.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
Else                         '不显示EXCEL
    xlApp.DisplayAlerts = False 'Excel的提示信息不出现(关键)
    strfilename1 = strFileName '调用保存对话框取得保存的路径
    If strfilename1 = "" Then  '用户点击了取消按钮
       xlApp.Quit
       Set xlApp = Nothing  '"交还控制给Excel
       Set xlBook = Nothing
       Set xlSheet = Nothing
    Else
       If Dir(strfilename1) = "" Then
          xlSheet.SaveAs strfilename1
          MsgBox "导出EXcel成功!" & Chr(13) & "文件保存在 " & strfilename1, vbOKOnly + vbInformation, "提示"
       Else
          If MsgBox("该文件已经存在，是否覆盖该文件！", vbYesNo + vbQuestion, "警告") = vbYes Then
             xlSheet.SaveAs strfilename1
             MsgBox "导出EXcel成功!" & Chr(13) & "文件保存在 " & strfilename1, vbOKOnly + vbInformation, "提示"
          End If
       End If
       xlApp.Quit
       Set xlApp = Nothing
       Set xlBook = Nothing
       Set xlSheet = Nothing
    End If
End If
End Function
'******************************************************************************************'第二个函数:(使用前新建一个名为Form1窗体把CommonDialog1放在上面)Public Function strFileName() As String'功能:取得保存的路径字符串
      On Error Resume Next
      Dim saveSign As Boolean
      Form1.CommonDialog1.CancelError = True
      Form1.CommonDialog1.FileName = "公司人员情况表" & Date  '默认生成的文件名
      Form1.CommonDialog1.DialogTitle = "保存文件"
      Form1.CommonDialog1.Filter = "Excel (*.xls)|*.xls|"
      Form1.CommonDialog1.DefaultExt = "*.xls"
      Form1.CommonDialog1.ShowSave
      If Err.Number = 32755 Then '当用户点击了取消按钮时退出
         strFileName = ""
         Exit Function
      End If
      strFileName = Form1.CommonDialog1.FileName
End Function
'*****************************************************************************************

Answer 1

其实不用控件也不需要这么烦 
var 
I: Integer; 
Str: String; 
StrList: TStringList;//用于存储数据的字符列表 
begin 
StrList := TStringList.Create; 
try 
with Table1 do 
begin 
First; 
while not Eof do 
begin 
Str := ''; 
for I := 0 to FieldCount-1 do 
Str := Str + Fields[I].AsString + #9; 
StrList.Add(Str); 
Next; 
end; 
StrList.SaveToFile('test.xls'); 
end; 
StrList.Free; 
except 
StrList.Free; 
end; 
end; 

Answer 2

前段时间由于程序中有类似的功能，我在网上找到了不少相关的资料，结合我自己的使用情况，总结出这两种比较简单的方法，有关代码借签部分网友的作品，在此表示感谢。
（一）利用Server面板上的三个Excel相关的组件excelApplication，Excelworksheet,excelworkbook,使用这些控件与Excel程序建立联系，同时此面板上还提供了操作Office的控件，具体使用方法，还请对此熟悉的高手提供一些资料.
具体操作代码如下：
procedure TJspdcxform.BitBtn1Click(Sender: TObject);//导出按纽
var  i,row:integer; 
begin
if SaveDialog1.Execute then//此处还用了一个保存对话框
begin
 Screen.Cursor:=crHourGlass;  //设置鼠标形状为沙漏状
 ExcelApplication1.Connect;//和excel连接如果没有Excel程序可能要出错
 ExcelApplication1.Workbooks.Add(Null,0);//为excel添加工作簿
 ExcelWorkBook1.ConnectTo(ExcelApplication1.Workbooks[1]);
 ExcelWorkSheet1.ConnectTo(ExcelWorkBook1.Sheets[1] as _WorkSheet); 
 if not Query1.Active then 
 begin
   QUERY1.Open;
 end;
 for i:=0 to QUERY1.Fields.Count-1 do     ExcelWorkSheet1.Cells.Item[1,i+1]:=dbgrid1.Columns.Items[i].Title.Caption;//把DBGRID的各字段名写入Excel第一行
row:=2;                           
//或用QUERY1.Fields[i].FieldName代替DBGRID1.columns.Items[i].Title.Caption那句
 while not QUERY1.Eof do 
 begin
   for i:=0 to QUERY1.Fields.Count-1 do
   begin     ExcelWorkSheet1.Cells.Item[row,i+1]:=QUERY1.Fields[i].AsString;
   end;//把查询结果写入到电子表格中
   row:=row+1; 
   QUERY1.Next; 
 end;
 ExcelWorkBook1.SaveCopyAs(SaveDialog1.FileName); 
 ExcelWorkBook1.Close(false);
  ExcelApplication1.Disconnect;
  ExcelApplication1.Quit;
  Screen.Cursor:=crDefault;
  Application.MessageBox('成功保存文件!','提示',0);
end;
end;（二）利用Ole创建Excel对象，然后再进行导出
procedure Tform1.SpeedButton5Click(sender:Tobject);
var Excel,Wrkbook,WrkSheet:olevariant;
I,row:integer;
BeginTry
  Excel:=CreateOleObjcet(‘Excel.Application’);
Except
  If Application.MessageBox(‘你的机器没安装Excel，是否继续志出？’，‘注意’，Mb_OkCancel)=Id_no  then  Exit;
End;If  SaveDialog1.Execute then
Begin
  WrkBook:=Excel.WorkBooks.Add;//建立工作簿
  Row:=1;
  SheetCout:=1;
While not Query1.Eof do 
Begin
  If Row=1 then for I:=0 to QUERY1.Fields.Count-1 do 
Excel.workbook.worksheets[SheetCount].Cell[Row,I+1].value:= dbgrid1.Columns.Items[i].Title.Caption;//把标题写入EXCEL
Inc(Row);
For I:=0 to QUERY1.Fields.Count-1 do
Excel.workbook.worksheets[SheetCount].Cell[Row,I+1].value:=query1.fields[i].asstring;
If Row>50000 then
Begin
  SheetCount:=SheetCount+1;
  Row:=1;
End;
Query1.Next;
End; 
Excel.Activeworkbook.SaveAs(saveDialog1.FileName);
WrkBook.Close;
Excel.quit;
Excel:=Unassigned;
ShowMessage(‘系统已经导出，请到’+SaveDialog1.FileName+’里查看’);
End;

Answer 3

http://cc.hbu.cn/lab/blog/more.asp?name=nzh&id=61