记录集导向Excel的方法1

Public Function ExporToExcel(Rs_Data As ADODB.Recordset)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：通过调用Sheets中QueryTable方式 将记录集导到其相应格式中
'* Input: rs_data 是个记录集
'* Output: 空
'*********************************************************
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

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")
xlApp.Visible = True

'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("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(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公司名称：" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
' End With

xlApp.Application.Visible = True
On Error Resume Next
xlBook.SaveAs
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
xlApp.Quit
End Function

 

posted on 2005-12-02 10:05 木子的blog 阅读(666)   

--------------------next---------------------