ADO把Recordset导入EXCEL后打印~ VB / 数据库(包含打印，安装，报表)...

bingge（兵哥）回复于 2005-01-25 10:03:20 得分 0
其实这个很简单的，里面好多代码你直接拷过去就能用，前提是你一些基本的vb要了解。我刚工作的时候，最初做的就是这个东东。Top
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
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