Public Sub ExportToExcel(ado As Adodc, DG As DataGrid, startCol As Integer, EndCol As Integer, StrTitle As String)
'输出到EXCEL表中
'数据来源于ado和dg，strtitle为第一行第一列显示的内容，即表名
'startCol为要导出的dataGrid的起始列，可能会需要不导出数据的前几列
'endCol为要导出的dataGrid的终止列

Dim Excel_File As New Excel.Application
Dim Excel_WorkBook As Excel.Workbook
Dim Excel_Sheet As Excel.Worksheet
Dim savename, s As String
Dim j, k As Integer
Dim jindu, k1 As Single

'创建excel文件
Frm_Main.CommonDialog1.filename = StrTitle
Frm_Main.CommonDialog1.Filter = "*.xls|*.xls"
Frm_Main.CommonDialog1.CancelError = True
On Error GoTo L1
Frm_Main.CommonDialog1.DialogTitle = "输入要创建的Excel文件名"
Frm_Main.CommonDialog1.FilterIndex = 2
Frm_Main.CommonDialog1.ShowSave
L1:
If err.Number = cdlCancel Then
err.Clear
Exit Sub
End If
If Frm_Main.CommonDialog1.filename = "" Then Exit Sub
savename = Frm_Main.CommonDialog1.filename
''拆分savenae并判　断有无此文件
If IsSaveFileNameExist(savename) = True Then
MsgBox "已有此文件，另输入一个文件名。"
Exit Sub
End If

FileCopy App.path & "\table.xls", savename

'打开创建的文件并输出
On Error GoTo 100
If ado.Recordset.RecordCount = 0 Then
MsgBox "无记录。", vbInformation + vbOKOnly, DlgTitle
Exit Sub
End If
Frm_JinDu.Show
Frm_JinDu.Command2.Enabled = False
Frm_JinDu.MousePointer = 11
'进度还原
Frm_JinDu.Label3.Width = 0
If ado.Recordset.RecordCount <= 0 Then
Exit Sub
End If
jindu = 100 / ado.Recordset.RecordCount
Frm_JinDu.Label1.Caption = "准备导出..."
Set Excel_File = CreateObject("Excel.application")
If Excel_File Is Nothing Then
MsgBox "请检查是否安装microsoft EXCEL软件", , DlgTitle
Exit Sub
End If
On Error GoTo 100
Set Excel_WorkBook = Excel_File.Workbooks.Open(savename)
If Excel_WorkBook Is Nothing Then
MsgBox "请检查是否存在" & savename & "文件。", , DlgTitle
Exit Sub
End If
Set Excel_Sheet = Excel_WorkBook.Worksheets("Sheet1")
If Excel_Sheet Is Nothing Then
MsgBox "请检查 " & savename & " 文件中SHEET1是否存在。", , DlgTitle
Exit Sub
End If
Excel_File.Sheets("Sheet1").Select
Excel_File.Range("A1:U100").Select
Excel_File.Selection.ClearContents
Excel_File.Range("A4").Select
s = "B2"
Excel_Sheet.Range(s).Font.Size = 12
Frm_JinDu.Label1.Caption = "正在导出..."
'表头
Excel_Sheet.Cells(1, 1) = StrTitle
For j = 0 To 0
DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
DG.Col = k
Excel_Sheet.Cells(j + 2, k + 1 - startCol) = DG.Columns(k).Caption
Next k
Next j
'表资料
ado.Recordset.MoveFirst
For j = 0 To ado.Recordset.RecordCount - 1
'DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
'DG.Col = k
Excel_Sheet.Cells(j + 3, k + 1 - startCol) = ado.Recordset.Fields(k).Value 'DG.Text
Next k
'显示进度
Frm_JinDu.Label3.Width = Frm_JinDu.Label3.Width + Frm_JinDu.Picture1.Width / ado.Recordset.RecordCount
k1 = k1 + jindu
DoEvents
Frm_JinDu.Label4.Caption = CInt(k1) & "%"
ado.Recordset.MoveNext
Next j

Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Frm_JinDu.Label1.Caption = "导出完成，数据被导入" & savename & "中。"
Frm_JinDu.Command2.Enabled = True
Frm_JinDu.Command2.SetFocus
Frm_JinDu.MousePointer = 0

Exit Sub

100:
MsgBox "导出出错。"
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Unload Frm_JinDu