Public Function ExporToExcel(strOpen As String, Connstr As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
'Dim cn As New ADODB.Connection
Dim Rs_Data As New ADODB.Recordset
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
' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "' ;Persist Security Info=False"
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Connection
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
With Rs_Data
' .MoveFirst
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"))
以上代码中,是接收的查询串,楼主问的是接收记录集,我的代码如下:分享:
Public Function rstoexcel(rstable As ADODB.Recordset, cexcelname As String) As Boolean
On Error GoTo gherr
Dim icol As Integer '列数,用于保存字段个数
Dim ijlts As Long '记录条数
Dim yesorno As Long '确认或是取消的标志
Dim AppExcel As Excel.Application '定义
Dim BookExcel As Excel.Workbook '工作簿对象
Dim sheetexcel As Excel.Worksheet '工作表
'如果没传过来文件名则返回
If Len(cexcelname) = 0 Then
Exit Function
End If
With rstable
If .RecordCount < 1 Then
MsgBox ("没有记录可供导出,该操作已经取消!")
rstoexcel = False
Exit Function
Else
icol = .Fields.Count '求字段数
ijlts = .RecordCount '求记录数
End If
End With
If Dir$(cexcelname) <> "" Then
yesorno = MsgBox("这个文件名已经存在,是否选择覆盖?如果该文件正处于打开状态由不能写入,请首先关闭该文件!", vbYesNo + vbDefaultButton2 + vbQuestion)
Else
yesorno = 6 '如果文件名并不存存,则置标志为可导出
End If
If yesorno <> 6 Then
rstoexcel = False
Exit Function
End If
Set AppExcel = New Excel.Application '创建excel对象
Set BookExcel = AppExcel.Workbooks.Add '添加工作簿
Set sheetexcel = BookExcel.Worksheets("sheet1") '添加工作表
For icol = 0 To rstable.Fields.Count - 1
AppExcel.Worksheets(1).Cells(1, icol + 1).Value = rstable.Fields(icol).Name
Next
AppExcel.Worksheets(1).Range("A2").CopyFromRecordset rstable
With sheetexcel
'.Range(.Cells(1, 1), .Cells(1, icol)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, icol)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(ijlts + 1, icol)).Borders.LineStyle = xlContinuous '如果第一行不显示字段,则不用加一
'设表格边框样式
End With
BookExcel.SaveAs (cexcelname)
'MsgBox ("该文件名已经存在,不能导出,否则将覆盖,请给出新的名称")
'rstoexcel = False
AppExcel.Quit
Set sheetexcel = Nothing
Set BookExcel = Nothing
Set AppExcel = Nothing
rstoexcel = True
Exit Function
gherr:
'MsgBox "电子表格导出失败,请检查该文件是否处理打开状态,错误信息如下:" & Chr(13) & Err.Number & "," & Err.Description
'MsgBox "由于未知原因,导出失败!", vbQuestion
rstoexcel = False
End Function