Public Function ExportToExcel(RSrecord As ADODB.Recordset, Titles_Name)
\’==================================================
\’参数说明
\’RSrecord ：记录集
\’titles_name 表头名称
\’==================================================
On Error GoTo ERRCL
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
\’ 假设Rs_Data 是你的记录集
With RSrecord
If .RecordCount < 1 Then
MsgBox “没有可导出的记录!”, vbInformation + vbOKOnly, “提示”
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”)
xlApp.Visible = True
\’添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(RSrecord, xlSheet.Range(“a2”))
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 8)).Merge
xlSheet.Cells(1, 1).HorizontalAlignment = xlCenter
xlSheet.Cells(1, 1) = Titles_Name
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(1, Icolcount)).Font.Name = “宋体”
\’设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
\’标题字体加粗
.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous
\’设表格边框样式
\’ .PageSetup.PaperSize = xlPaperA4 \’
\’ .PageSetup.PrintGridlines = True
End With
xlApp.Application.Visible = True
Set xlApp = Nothing \'”交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Set Rs_Data = Nothing
Exit Function
ERRCL: MsgBox “无有效数据或 Excel 2000 未安装！”, vbInformation, “错误”
End Function
