【源代码共享】VB+ADO导出EXCEL

'把系统中常用的导出EXCEL的代码贴出来与大家共享

Public Sub OutExcel(ByVal Myrestr As ADODB.Recordset, ByVal outFile As String, ByVal toTal1 As String, ByVal toTal2 As String)
'导出EXCEL文件

'说明：Myrestr为已生成需要导出的数据集

'         outFile为EXCEL文件名

'          toTal1 ，toTal2为汇总内容

If Myrestr.RecordCount > 0 Then
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim app_add As Long
Dim appII%
'Load FormWait
'FormWait.Label1.Caption = "正在生成EXCEL文件............"
   
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    Set xlBook = xlApp.Workbooks.Add    'xlApp.Workbooks.Open("文件名") '打开已经存在的EXCEL工件簿文件
    xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    Set xlSheet = xlBook.Worksheets(1) '设置活动工作表 sheet1(若要放在sheet2，则xlBook.Worksheets(2) )
    xlSheet.Activate
For appII% = 0 To Myrestr.Fields.Count - 1
xlSheet.Cells(1, appII% + 1) = Myrestr.Fields(appII%).Name
xlApp.ActiveSheet.Cells(1, appII% + 1).Font.Name = "黑体"
Next appII%
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, appII%)).Borders.LineStyle = xlContinuous

Myrestr.MoveFirst
app_add = 2
Do While Not Myrestr.EOF
For appII% = 0 To Myrestr.Fields.Count - 1
xlSheet.Cells(app_add, appII% + 1) = "'" & Myrestr.Fields(appII%)
Next appII%
app_add = app_add + 1
Myrestr.MoveNext
Loop
xlSheet.Cells(app_add + 1, 2) = "'" & toTal1
xlSheet.Cells(app_add + 2, 2) = "'" & toTal2
   xlBook.SaveAs (outFile)
    If Not (xlApp Is Nothing) Then        
        xlBook.Close (True) '关闭工作簿
        xlApp.Quit '必须结束EXCEL对象
        Set xlApp = Nothing '释放xlApp对象
        Set xlBook = Nothing
        Set xlSheet = Nothing
    End If
'Unload FormWait
MsgBox "导出EXCEL完毕！", vbSystemModal + vbInformation, "导出EXCEL"
End If

End Sub