vb记录集数据导入到excel

Public Sub DGToExcel(DataGrid1 As DataGrid, Optional ProgressBar1 As ProgressBar, Optional ByVal intFirst As Integer, Optional ByVal intLast As Integer, Optional strTitle As String)
'--将DataGrid导出至Excel,ProgressBar1为进度条,intFirst为从哪一列开始打印,intLast为打印到哪一列
On Error Resume Next
Dim I As Long
Dim J As Integer
Dim K As Integer
Dim sLast As String
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Name = "查询结果"
xlApp.Visible = False '--先隐藏
ProgressBar1.Value = 0
Screen.MousePointer = 11
ProgressBar1.Max = DataGrid1.ApproxCount + 3
'--设置标题
sLast = Chr(Asc("A") + intLast - intFirst)
xlApp.Range("A1:" & sLast & "2").Select
With xlApp.Selection '--合并单元格
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
ProgressBar1.Value = 1
xlApp.Selection.Merge
With xlApp.Selection.Font '--字体
.FontStyle = "加粗"
.SIZE = 24
End With
xlApp.Range("A1:" & sLast & "2").Select
xlApp.ActiveCell.FormulaR1C1 = strTitle
ProgressBar1.Value = 2
'--设置列
For K = 0 To intLast - intFirst '显示选中的列
xlSheet.Cells(3, K + 1) = DataGrid1.Columns(K + intFirst).Caption '第一行为DataGrid的列标题
Next
xlApp.Range("A3:" & sLast & "3").Select
With xlApp.Selection.Font
.Name = "宋体"
.FontStyle = "加粗"
.SIZE = 12
End With
DataGrid1.Scroll 0, -DataGrid1.FirstRow '导出前拉动过垂直滚动条，这个非常重要
DataGrid1.Row = 0
For I = 0 To DataGrid1.ApproxCount - 1 'DataGrid的所有行数
For J = 0 To intLast - intFirst 'DataGrid数,若将此数改小到不拉DataGrid的垂直滚动条的时候能看见的行数的时候正常
DataGrid1.Col = J + intFirst
xlSheet.Cells(I + 4, J + 1) = DataGrid1.Text '从第二行显示'DataGrid的内容
Next J
If I < DataGrid1.ApproxCount - 1 Then
DataGrid1.Row = DataGrid1.Row + 1
End If
ProgressBar1.Value = I + 2
Next I
'--自动调整列宽
xlApp.Range("A:" & sLast).Select

xlApp.Selection.Columns.AutoFit
Screen.MousePointer = 0
ProgressBar1.Max = DataGrid1.ApproxCount
xlApp.WindowState = xlMaximized
xlApp.Visible = True
Set xlApp = Nothing 'Excel 处于当前窗体
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
err:
MsgBox err.Description
End Sub