低温冷冻果蔬干燥机:ADO把Recordset导入EXCEL后打印~ VB / 数据库(包含打印，安装，报表)...

来源：百度文库编辑：偶看新闻时间：2024/04/29 22:45:47

CSDN社区 > VB > 数据库(包含打印，安装，报表)

ADO把Recordset导入EXCEL后打印~

楼主rolleyuan（想展翅高飞的人）2005-01-24 23:48:23 在 VB / 数据库(包含打印，安装，报表) 提问

如题~我看到很多这样的代码,但或多或少都有点问题,如果有高手给个模快最好啦~小D先谢谢了问题点数：20、回复次数：3Top

1 楼bingge（兵哥）回复于 2005-01-25 10:03:20 得分 0

其实这个很简单的，里面好多代码你直接拷过去就能用，前提是你一些基本的vb要了解。我刚工作的时候，最初做的就是这个东东。Top

2 楼icedut（冰-装修进行中）回复于 2005-01-25 10:07:45 得分 10

转
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 cn As New ADODB.Connection
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 = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;"
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.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"))

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh

xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

End Function
-------------------------------------------------------------------------------
'*************************************************************************
'**
'** VB将数据导出到EXCEL,没有安装EXCEL的一样也可以导出.
'**
'** 调用方式: s_Export2Excel(Ado.Recordset) 或 s_Export2Excel(Rds.RecordSet)
'** 支持 Rds 与 Ado 的记录导出
'**
'*************************************************************************

'导出ADO记录集到EXCEL
Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal sExcelFileName$ _
, Optional ByVal sTableName$, Optional ByVal sOverExist As Boolean = False) As Boolean

'On Error GoTo lbErr

Dim iConcStr, iSql$, iFdlist$, iDb As ADODB.Connection
Dim iI&, iFdType$, j, TmpField, FileName
Dim iRe As Boolean

'检查文件名
If Dir(sExcelFileName) <> "" Then
If sOverExist Then
Kill sExcelFileName
Else
iRe = False
GoTo lbExit
End If
End If

'生成创建表的SQL语句
With sRecordSet
For iI = 0 To .Fields.Count - 1
iFdType = f_FieldType(.Fields(iI).Type)
Select Case iFdType
Case "char", "varchar", "nchar", "nvarchar", "varbinary"
If .Fields(iI).DefinedSize > 255 Then
iSql = iSql & ",[" & .Fields(iI).Name & "] text"
Else
iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType & _
"(" & .Fields(iI).DefinedSize & ")"
End If
Case "image"
Case Else
iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType
End Select
Next

If sTableName = "" Then sTableName = .Source
iSql = "create table [" & sTableName & "](" & Mid(iSql, 2) & ")"
End With

'数据库连接字符串
iConcStr = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;" & _
"CREATE_DB=""" & sExcelFileName & """;DBQ=" & sExcelFileName

'创建Excel文件,并创建表
Set iDb = New ADODB.Connection
iDb.Open iConcStr
iDb.Execute iSql

'插入数据
With sRecordSet
.MoveFirst
While .EOF = False
iSql = ""
iFdlist = ""
For iI = 0 To .Fields.Count - 1
iFdType = f_FieldType(.Fields(iI).Type)
If iFdType <> "image" And IsNull(.Fields(iI).Value) = False Then
iFdlist = iFdlist & ",[" & .Fields(iI).Name & "]"
Select Case iFdType
Case "char", "varchar", "nchar", "nvarchar", "text"
iSql = iSql & ",'" & .Fields(iI).Value & "'"
Case "datetime"
iSql = iSql & ",#" & .Fields(iI).Value & "#"
Case "image"
Case Else
iSql = iSql & "," & .Fields(iI).Value
End Select
End If
Next
iSql = "insert into [" & sTableName & "](" & _
Mid(iFdlist, 2) & ") values(" & Mid(iSql, 2) & ")"
iDb.Execute iSql
.MoveNext
Wend
End With

'处理完毕,关闭数据库
iDb.Close
Set iDb = Nothing

MsgBox "已经将数据保存到 [ " & sExcelFileName & " ]", 64
iRe = True
GoTo lbExit

lbErr:
MsgBox "发生错误:" & Err.Description & vbCrLf & _
"错误代码:" & Err.Number, 64, "错误"
lbExit:
f_Export2Excel = iRe
End Function

'得到所有数据类型,有些数据类型EXCEL不支持,已经替换掉
Public Function f_FieldType$(ByVal sType&)
Dim iRe$
Select Case sType
Case 2, 3, 20
iRe = "int"
Case 5
iRe = "float"
Case 6
iRe = "money"
Case 131
iRe = "numeric"
Case 4
iRe = "real"
Case 128
iRe = "binary"
Case 204
iRe = "varbinary"
Case 11
iRe = "bit"
Case 129, 130
iRe = "char"
Case 17, 72, 131, 200, 202, 204
iRe = "varchar"
Case 201, 203
iRe = "text"
Case 7, 135
iRe = "datetime"
Case 205
iRe = "image"
Case 128
iRe = "timestamp"
End Select
f_FieldType = iRe
End Function

'调用测试
Sub test()
Dim iRe As ADODB.Recordset
Dim iConc As String

iConc = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False" & _
";Data Source=F:\My Documents\客户资料.mdb"

Set iRe = New ADODB.Recordset
iRe.Open "维护员", iConc, adOpenKeyset, adLockOptimistic
f_Export2Excel iRe, "c:\b.xls", , True
iRe.Close
End Sub
Top

3 楼wumylove1234（毁于随）回复于 2005-01-25 12:38:03 得分 10

Option Explicit

'Private xlApp As Excel.Application
'Private xlBook As Excel.Workbook
'Private xlSheet As Excel.Worksheet
Private xlApp As Object
Private xlBook As Object
Private xlSheet As Object

Private cellValue As String

Public strError As String
Public ExportOK As Boolean
Private Sub Class_Initialize()
ExportOK = False
On Error GoTo errHandle:
' Set xlApp = CreateObject("Excel.Applaction")
Set xlApp = New Excel.Application
xlApp.Visible = False
On Error GoTo errHandle:
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
If Val(xlApp.Application.Version) >= 8 Then
Set xlSheet = xlApp.ActiveSheet
Else
Set xlSheet = xlApp
End If
Exit Sub
errHandle:
Err.Raise 100001, , "建立Excel对象时发生错误:" & Err.Description & vbCr & _
"请确保您正确了安装了Excel软件!"
End Sub

Public Property Get TextMatrix(Row As Integer, Col As Integer) As Variant
TextMatrix = xlSheet.Cells(Row, Col)
End Property
Public Property Let TextMatrix(Row As Integer, Col As Integer, Value As Variant)
xlSheet.Cells(Row, Col) = Value
End Property

'合并单元格
Public Sub MergeCell(bRow As Integer, bCol As Integer, eRow As Integer, eCol As Integer)
xlSheet.Range(GetExcelCell(bRow, bCol) & ":" & GetExcelCell(eRow, eCol)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
End Sub
'打印预览
Public Function PrintPreview() As Boolean
On Error GoTo errHandle:
xlApp.Visible = True
xlBook.PrintPreview True
Exit Function
errHandle:
If Err.Number = 1004 Then
MsgBox "尚未安装打印机,不能预览!", vbOKOnly + vbCritical, "错误"
End If
End Function
'导出
Public Function ExportExcel() As Boolean
xlApp.Visible = True
End Function
'画线
Public Sub DrawLine(bRow As Integer, bCol As Integer, eRow As Integer, eCol As Integer)
On Error Resume Next
xlSheet.Range(GetExcelCell(bRow, bCol) & ":" & GetExcelCell(eRow, eCol)).Select
xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
'导出记录集到Excel
Public Sub RstExport(Rst As ADODB.Recordset, bRow As Integer, bCol As Integer, GridHead() As String)
Dim i As Integer, j As Integer
For i = bCol To UBound(GridHead) + bCol
With Me
.TextMatrix(bRow, i) = GridHead(i - bCol)
End With
Next
i = 1 + bRow
Do While Not Rst.EOF
For j = 1 To Rst.Fields.Count
If Rst.Fields(j - 1).Type = adChar Or Rst.Fields(j - 1).Type = adVarChar Then
xlSheet.Range(GetExcelCell(i, j) & ":" & GetExcelCell(i, j)).Select
xlApp.Selection.NumberFormatLocal = "@" '已文本方式格式化
End If
Me.TextMatrix(i, j) = checkNull(Rst.Fields(j - 1).Value)
Next
i = i + 1
Rst.MoveNext
Loop
End Sub

'或者指定行,列号的Excel编码
Private Function GetExcelCell(Row As Integer, Col As Integer) As String
Dim nTmp1 As Integer
Dim nTmp2 As Integer
Dim sTmp As String
If Col <= 26 Then
sTmp = Chr(Asc("A") + Col - 1)
Else
nTmp1 = Col \ 26
If nTmp1 > 26 Then
Err.Raise 100000, , "列数过大,发生错误"
Exit Function
Else
sTmp = Chr(Asc("A") + nTmp1 - 1)
nTmp1 = Col Mod 26
sTmp = sTmp & Chr(Asc("A") + nTmp1 - 1)
End If
End If
GetExcelCell = sTmp & Row
End Function
'将Null返回为空串
Private Function checkNull(s As Variant) As String
checkNull = IIf(IsNull(s), "", s)
End Function

Private Sub Class_Terminate()
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End Sub

这是我写的类.Top

关键词

excel
代码
数据
isql
ifdtype
sexcelfilename
exportoexcel
ifdlist
idb
stablename

得分解答快速导航

帖主：rolleyuan
icedut
wumylove1234

广告也精彩

怎样通过asp中的ADO把excel中数据导入到Access数据库中？如何把Excel导入VFP? 在ADO的Recordset中二次查询 ado中有关recordset的delete方法关于ADO RecordSet类Addnew方法的问题 vb编程中ADO中RECORDSET中Fields的问题 vb ado 连接mysql，打开recordset时报错。 ado访问EXCEL的问题 vb中怎样把ado控件的查询记录输出到excel表格中？如何把Excel里的数据导入到Access里面怎么把excel中的数据导入数据库,谢谢怎么把excel中的数据导入数据库,谢谢怎么把excel中的数据导入数据库,谢谢如何把EXCEL数据导入WORD中处理？怎样把excel中的数据导入到spss12.0 怎样可以把网站的数据导入到excel里？怎样把excel里面的内容导入到word里面？怎麼样把文本文档导入到excel中啊？怎样把microsoft Excel中的数据导入visual foxpor？怎么样把WORD表格导入为EXCEL表格？如何把excel导入corel中以后是可编缉的呢? 怎么样把oracle表结构和数据导入到excel 怎么样把WORD表格导入为EXCEL表格？怎么样把EXCEL表格导出WORD为表格？ EXCEL高手请进：请问怎么把幻灯片导入到EXCEL表格中.具体一点好吗?