Public Function ExportToExcel(Rs_Data As ADODB.Recordset, Titles_Name)
On Error GoTo ERRCL
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是你的记录集
If Rs_Data.RecordCount < 1 Then
MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
Exit Function
End If
'记录总数
Irowcount = Rs_Data.RecordCount
'字段总数
Icolcount = Rs_Data.Fields.Count
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
' .PageSetup.PaperSize = xlPaperA4 '
' .PageSetup.PrintGridlines = True
End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function
ERRCL: MsgBox "无有效数据或 Excel 2000 未安装!", vbInformation, "错误"
End Function
在程序中引用Microsoft Excel 9.0 Object Library,将下文加入到一个模块中,窗体中调用如下ExporToExcel("select * from table")。则实现快速将数据导出到EXCEL中。
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
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
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
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"))
Public Sub doExport(ByVal caption As String, ByVal text As String, ByVal MsgHwnd As Long, _
ByVal grid As DataGrid, _
ByVal rs As ADODB.Recordset)
If UCase(TypeName(rs)) = "Nothing" Then
Exit Sub
End If
If rs.Fields.Count = 0 Or grid.Columns.Count = 0 Then
Exit Sub
End If
Dim Fn As String
Fn = FileDialog.SaveDialog(MsgHwnd)
If Fn = "" Then Exit Sub
If Not EndWith(Fn, ".xls") Then Fn = Fn & ".xls"
Dim xls As Excel.Application
Dim w As Excel.Workbook
Dim e As Excel.Worksheet
Screen.MousePointer = 11
On Error Resume Next
Set xls = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Sorry, create Excel object exception. Please check if Excel installed."
Exit Sub
End If
On Error GoTo 0
xls.Visible = True
If fileExists(Fn) Then
Set w = xls.Workbooks.Open(Fn)
Else
Set w = xls.Workbooks.Add()
End If
Set e = w.Worksheets.Add()
Dim line As Long, iP As Integer
line = 1
If caption <> "" Then
e.cells(line, grid.Columns.Count / 2) = caption
line=line+1
End If
If text <> "" Then
If grid.Columns.Count > 2 Then
e.cells(line, CInt(grid.Columns.Count / 2) - 1) = text
Else
e.cells(line, grid.Columns.Count / 2) = text
End If
line=line+1
End If
For iP = 0 To grid.Columns.Count - 1
e.cells(line, 1 + iP) = grid.Columns(iP).caption
Next iP
Call inc(line)
If Not (rs.EOF And rs.BOF) Then
Dim bm As Long
bm = rs.Bookmark
rs.MoveFirst
Do While Not rs.EOF
e.cells(line, 1) = rs.Fields("PName").value
e.cells(line, 2) = rs.Fields("PAge").value
e.cells(line, 3) = rs.Fields("PGender").value
e.cells(line, 4) = rs.Fields("PPhone").value
e.cells(line, 5) = rs.Fields("PContent").value
e.cells(line, 6) = rs.Fields("FinishDT").value
e.cells(line, 7) = rs.Fields("FinishBy").value
e.cells(line, 8) = rs.Fields("PResult").value
e.cells(line, 9) = rs.Fields("Remark1").value
e.cells(line, 10) = rs.Fields("Remark2").value
line=line+1
rs.MoveNext
Loop
On Error Resume Next
rs.MoveFirst
If rs.Bookmark <> bm Then rs.Bookmark = bm
End If
e.Range("A1", "Z" & line).Columns.AutoFit
On Error GoTo 0
xls.DisplayAlerts = False
If fileExists(Fn) Then w.Save Else w.SaveAs Fn
w.Close
xls.Quit
Sleep 300
Set w = Nothing
Set xls = Nothing
Screen.MousePointer = 0
End Sub