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

  '*********************************************************   
  '*   名称：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