如何将VB中的数据导出excel,word中去!

VB: 怎样将查询结果导出到Excel


    如果你想将查询结果导出到Excel另存,以便日后查看或打印的话,那么我这里说的就是怎样将查询结果导出到Excel。先来写一个函数
FillDataArray,该函数的主要作用是将查询语句中的字段名和查到的记录导入到Excel中。

    Public Function FillDataArray(asArray(), adoRS As ADODB.Recordset) As Long
    '将数据送 Excel 函数
    Dim nRow As Integer
    Dim nCol As Integer
    On Error GoTo FillError
    ReDim asArray(100000, adoRS.Fields.Count)
    nRow = 0
     For nCol = 0 To adoRS.Fields.Count - 1
     asArray(nRow, nCol) = adoRS.Fields(nCol).name
     Next nCol
     nRow = 1
    Do While Not adoRS.EOF
     For nCol = 0 To adoRS.Fields.Count - 1
     asArray(nRow, nCol) = adoRS.Fields(nCol).Value
     Next nCol
     adoRS.MoveNext
     nRow = nRow + 1
    Loop
    nRow = nRow + 1
    FillDataArray = nRow
    Exit Function
FillError:
     MsgBox Error$
     Exit Function
     Resume
    End Function

 然后再来写一个过程PrintList,来调用前面的这个函数。

    Private Sub PrintList()
    Dim strSource, strDestination As String
    Dim asTempArray()
    Dim INumRows As Long
    Dim objExcel As Excel.Application
    Dim objRange As Excel.Range
    On Error GoTo ExcelError
    Set objExcel = New Excel.Application '新建一个Excel
    Dim rs As New ADODB.Recordset
  Set rs = Conn.Execute(sqlall)‘sqlall是查询语句
    If Not rs.EOF Then
     objExcel.Workbooks.Open App.Path & "/vvv.xls"
     MsgBox "查询结果导出后,请将其另存为一个.xls文件,使vvv.xls中的内容为空,确保后面查询结果的正确导出。"
     INumRows = FillDataArray(asTempArray, rs) '调填充数组函数
     objExcel.cells(1, 1) = "查询结果" '填表头
     Set objRange = objExcel.Range(objExcel.cells(2, 1), objExcel.cells(INumRows, rs.Fields.Count))
     objRange.Value = asTempArray '填数据
    End If
     objExcel.Visible = True '显示Excel
     objExcel.DisplayAlerts = True '提示保存Excel
     Exit Sub
ExcelError:
     If Err <> 432 And Err > 0 Then
     MsgBox Error$
     Set objExcel = Nothing
     Exit Sub
     Else
     Resume Next
     End If
    End Sub

  其中用到的vvv.xls必须是先建好了的xls文件。结果导出后不要直接保存,而要将其另存为一个.xls文件,使vvv.xls中的内容为空,确保
后面查询结果的正确导出?

------------------------------------------------------------------------------------------------
如何操作Excel文件  
  全面控制   Excel  
  首先创建   Excel   对象,使用ComObj:  
  Dim   ExcelID   as   Excel.Application  
  Set   ExcelID   as   new   Excel.Application  
  1)   显示当前窗口:  
  ExcelID.Visible   :=   True;  
  2)   更改   Excel   标题栏:  
  ExcelID.Caption   :=   '应用程序调用   Microsoft   Excel';  
  3)   添加新工作簿:  
      ExcelID.WorkBooks.Add;  
  4)   打开已存在的工作簿:  
      ExcelID.WorkBooks.Open(   'C:/Excel/Demo.xls'   );  
  5)   设置第2个工作表为活动工作表:  
      ExcelID.WorkSheets[2].Activate;      
    或   ExcelID.WorkSheets[   'Sheet2'   ].Activate;  
  6)   给单元格赋值:  
    ExcelID.Cells[1,4].Value   :=   '第一行第四列';  
  7)   设置指定列的宽度(单位:字符个数),以第一列为例:  
    ExcelID.ActiveSheet.Columns[1].ColumnsWidth   :=   5;  
  8)   设置指定行的高度(单位:磅)(1磅=0.035厘米),以第二行为例:  
      ExcelID.ActiveSheet.Rows[2].RowHeight   :=   1/0.035;   //   1厘米  
  9)   在第8行之前插入分页符:  
      ExcelID.WorkSheets[1].Rows[8].PageBreak   :=   1;  
  10)   在第8列之前删除分页符:  
      ExcelID.ActiveSheet.Columns[4].PageBreak   :=   0;  
  11)   指定边框线宽度:  
    ExcelID.ActiveSheet.Range[   'B3:D4'   ].Borders[2].Weight   :=   3;  
        1-左         2-右       3-顶         4-底       5-斜(   /   )           6-斜(   /   )  
  12)   清除第一行第四列单元格公式:  
    ExcelID.ActiveSheet.Cells[1,4].ClearContents;  
  13)   设置第一行字体属性:  
  ExcelID.ActiveSheet.Rows[1].Font.Name   :=   '隶书';  
  ExcelID.ActiveSheet.Rows[1].Font.Color     :=   clBlue;  
  ExcelID.ActiveSheet.Rows[1].Font.Bold       :=   True;  
  ExcelID.ActiveSheet.Rows[1].Font.UnderLine   :=   True;  
  14)   进行页面设置:  
      a.页眉:  
          ExcelID.ActiveSheet.PageSetup.CenterHeader   :=   '报表演示';  
      b.页脚:  
          ExcelID.ActiveSheet.PageSetup.CenterFooter   :=   '第&P页';  
      c.页眉到顶端边距2cm:  
          ExcelID.ActiveSheet.PageSetup.HeaderMargin   :=   2/0.035;  
      d.页脚到底端边距3cm:  
          ExcelID.ActiveSheet.PageSetup.HeaderMargin   :=   3/0.035;  
      e.顶边距2cm:  
          ExcelID.ActiveSheet.PageSetup.TopMargin   :=   2/0.035;  
      f.底边距2cm:  
          ExcelID.ActiveSheet.PageSetup.BottomMargin   :=   2/0.035;  
      g.左边距2cm:  
          ExcelID.ActiveSheet.PageSetup.LeftMargin   :=   2/0.035;  
      h.右边距2cm:  
          ExcelID.ActiveSheet.PageSetup.RightMargin   :=   2/0.035;  
      i.页面水平居中:  
          ExcelID.ActiveSheet.PageSetup.CenterHorizontally   :=   2/0.035;  
      j.页面垂直居中:  
          ExcelID.ActiveSheet.PageSetup.CenterVertically   :=   2/0.035;  
      k.打印单元格网线:  
          ExcelID.ActiveSheet.PageSetup.PrintGridLines   :=   True;  
  15)   拷贝操作:  
      a.拷贝整个工作表:  
          ExcelID.ActiveSheet.Used.Range.Copy;  
      b.拷贝指定区域:  
          ExcelID.ActiveSheet.Range[   'A1:E2'   ].Copy;  
      c.从A1位置开始粘贴:  
          ExcelID.ActiveSheet.Range.[   'A1'   ].PasteSpecial;  
      d.从文件尾部开始粘贴:  
          ExcelID.ActiveSheet.Range.PasteSpecial;  
  16)   插入一行或一列:  
        a.   ExcelID.ActiveSheet.Rows[2].Insert;  
        b.   ExcelID.ActiveSheet.Columns[1].Insert;  
  17)   删除一行或一列:  
      a.   ExcelID.ActiveSheet.Rows[2].Delete;  
      b.   ExcelID.ActiveSheet.Columns[1].Delete;  
  18)   打印预览工作表:  
      ExcelID.ActiveSheet.PrintPreview;  
  19)   打印输出工作表:  
      ExcelID.ActiveSheet.PrintOut;  
  20)   工作表保存:  
    If   not   ExcelID.ActiveWorkBook.Saved   then  
        ExcelID.ActiveSheet.PrintPreview  
        End   if  
  21)   工作表另存为:  
      ExcelID.SaveAs(   'C:/Excel/Demo1.xls'   );  
  22)   放弃存盘:  
    ExcelID.ActiveWorkBook.Saved   :=   True;  
  23)   关闭工作簿:  
    ExcelID.WorkBooks.Close;  
  24)   退出   Excel:  
  ExcelID.Quit;  
  25)   设置工作表密码:  
  ExcelID.ActiveSheet.Protect   "123",   DrawingObjects:=True,   Contents:=True,   Scenarios:=True  
  26)     EXCEL的显示方式为最大化  
  ExcelID.Application.WindowState   =   xlMaximized          
  27)   工作薄显示方式为最大化  
  ExcelID.ActiveWindow.WindowState   =   xlMaximized      
  28)   设置打开默认工作薄数量  
  ExcelID.SheetsInNewWorkbook   =   3  
  29)   '关闭时是否提示保存(true   保存;false   不保存)  
  ExcelID.DisplayAlerts   =   False      
  30)   设置拆分窗口,及固定行位置  
  ExcelID.ActiveWindow.SplitRow   =   1  
  ExcelID.ActiveWindow.FreezePanes   =   True  
  31)   设置打印时固定打印内容  
  ExcelID.ActiveSheet.PageSetup.PrintTitleRows   =   "$1:$1"      
  32)   设置打印标题  
  ExcelID.ActiveSheet.PageSetup.PrintTitleColumns   =   ""        
  33)   设置显示方式(分页方式显示)  
  ExcelID.ActiveWindow.View   =   xlPageBreakPreview      
  34)   设置显示比例  
  ExcelID.ActiveWindow.Zoom   =   100                                    
  35)   让Excel   响应   DDE   请求  
  Ex.Application.IgnoreRemoteRequests   =   False  
   
  用VB操作EXCEL  
  Private   Sub   Command3_Click()  
  On   Error   GoTo   err1  
          Dim   i   As   Long  
          Dim   j   As   Long  
          Dim   objExl   As   Excel.Application       '声明对象变量  
          Me.MousePointer   =   11                         '改变鼠标样式  
          Set   objExl   =   New   Excel.Application   '初始化对象变量  
          objExl.SheetsInNewWorkbook   =   1     '将新建的工作薄数量设为1  
          objExl.Workbooks.Add                     '增加一个工作薄  
          objExl.Sheets(objExl.Sheets.Count).Name   =   "book1"     '修改工作薄名称    
          objExl.Sheets.Add   ,   objExl.Sheets("book1")   ‘增加第二个工作薄在第一个之后  
          objExl.Sheets(objExl.Sheets.Count).Name   =   "book2"    
          objExl.Sheets.Add   ,   objExl.Sheets("book2")   ‘增加第三个工作薄在第二个之后  
  objExl.Sheets(objExl.Sheets.Count).Name   =   "book3"    
   
  objExl.Sheets("book1").Select           '选中工作薄<book1>  
          For   i   =   1   To   50                                       '循环写入数据  
                  For   j   =   1   To   5  
  If   i   =   1   Then  
                      objExl.Selection.NumberFormatLocal   =   "@"     '设置格式为文本    
  objExl.Cells(i,   j)   =   "   E   "   &   i   &   j  
                          Else  
                                objExl.Cells(i,   j)   =   i   &   j  
                          End   If  
                  Next  
          Next  
   
        objExl.Rows("1:1").Select                   '选中第一行  
        objExl.Selection.Font.Bold   =   True       '设为粗体  
        objExl.Selection.Font.Size   =   24           '设置字体大小  
        objExl.Cells.EntireColumn.AutoFit     '自动调整列宽    
  objExl.ActiveWindow.SplitRow   =   1     '拆分第一行  
        objExl.ActiveWindow.   SplitColumn   =   0     '拆分列  
  objExl.ActiveWindow.FreezePanes   =   True       '固定拆分       objExl.ActiveSheet.PageSetup.PrintTitleRows   =   "$1:$1"     '设置打印固定行  
  objExl.ActiveSheet.PageSetup.PrintTitleColumns   =   ""         '打印标题         objExl.ActiveSheet.PageSetup.RightFooter   =   "打印时间:   "   &   _  
                                        Format(Now,   "yyyy年mm月dd日   hh:MM:ss")  
        objExl.ActiveWindow.View   =   xlPageBreakPreview         '设置显示方式  
        objExl.ActiveWindow.Zoom   =   100                                   '设置显示大小  
          '给工作表加密码  
  objExl.ActiveSheet.Protect   "123",   DrawingObjects:=True,     _  
  Contents:=True,   Scenarios:=True  
        objExl.Application.IgnoreRemoteRequests   =   False  
        objExl.Visible   =   True                                               '使EXCEL可见  
        objExl.Application.WindowState   =   xlMaximized   'EXCEL的显示方式为最大化  
        objExl.ActiveWindow.WindowState   =   xlMaximized   '工作薄显示方式为最大化  
        objExl.SheetsInNewWorkbook   =   3                       '将默认新工作薄数量改回3个    
        Set   objExl   =   Nothing         '清除对象  
        Me.MousePointer   =   0       '修改鼠标  
  Exit   Sub  
  err1:  
  objExl.SheetsInNewWorkbook   =   3  
  objExl.DisplayAlerts   =   False     '关闭时不提示保存  
  objExl.Quit                                 '关闭EXCEL  
  objExl.DisplayAlerts   =   True       '关闭时提示保存  
  Set   objExl   =   Nothing  
  Me.MousePointer   =   0  
  End   Sub  
------------------------------------------------------------------------------------------
'利用   Word   打印的例子  
   
  Dim   oWord   As   Word.Application  
  Dim   oDoc   As   Word.Document  
  Dim   oRange   As   Word.Range  
  Dim   sTemp,   sHeadline,   sTitle   As   String  
  Dim   i   As   Integer  
  Dim   oldRec   As   Long  
   
  On   Error   GoTo   eh  
  If   adc_card.Recordset.RecordCount   =   0   Then   MsgBox   "没有可打印的数据!",   vbCritical:   Exit   Sub  
  oldRec   =   adc_card.Recordset.AbsolutePosition  
   
  '   Create   an   instance   of   Word  
  Set   oWord   =   CreateObject("Word.Application")  
  '   Add   a   new,   blank   document  
  Set   oDoc   =   oWord.Documents.add  
  oDoc.PageSetup.Orientation   =   wdOrientLandscape  
   
  '   Get   the   current   document's   range   object  
  Set   oRange   =   oDoc.Range  
  sTitle   =   Format(DTPicker1.value,   "yyyy年mm月dd日")   &   Combo1   &   IIf(Len(Text4),   "(",   "")   &   Text4   &   IIf(Len(Text4),   ")",   "")   &   "消费记录明细表"   &   vbCrLf   &   vbCrLf  
  oRange.Text   =   sTitle  
   
  oRange.SetRange   Len(sTitle)   +   1,   Len(sTitle)   +   1  
  adc_card.Recordset.MoveFirst  
  sTemp   =   adc_card.Recordset.GetString(adClipString,   -1,   vbTab)  
  For   i   =   0   To   Datagrid1.Columns.Count   -   1  
  sHeadline   =   sHeadline   &   Datagrid1.Columns(i).Caption   &   vbTab  
  Next   i  
  sHeadline   =   Left(sHeadline,   Len(sHeadline)   -   1)   &   vbCrLf  
   
   
  '   Insert   a   heading   on   the   string  
  sTemp   =   sHeadline   &   sTemp  
  '   Insert   the   data   into   the   Word   document  
  oRange.Text   =   sTemp  
  '   Convert   the   text   to   a   table   and   format   the   table  
  oRange.ConvertToTable   vbTab,   ,   ,   ,   36  
   
  oRange.SetRange   oRange.End   +   1,   oRange.End   +   1  
  oRange.Text   =   vbCrLf   &   "制表人:"   &   AdminName   &   vbTab   &   vbTab   _  
          &   "制表日期:"   &   Format(Date,   "long   date")  
  oRange.ParagraphFormat.Alignment   =   wdAlignParagraphRight  
   
  oDoc.Tables(1).Select  
  With   oWord.Selection  
  .Cells.HeightRule   =   wdRowHeightAtLeast  
  .Cells.Height   =   16  
  .Cells.VerticalAlignment   =   wdCellAlignVerticalCenter  
  End   With  
   
  oDoc.Tables(1).Columns(2).Width   =   40  
  oDoc.Tables(1).Columns(8).Width   =   oDoc.Tables(1).Columns(8).Width   +   50  
  For   i   =   2   To   adc_card.Recordset.RecordCount   +   1  
  oDoc.Tables(1).Cell(i,   4).Select  
  oWord.Selection.Text   =   Format(Val(oWord.Selection.Text),   "currency")  
  Next   i  
  oDoc.Tables(1).Cell(1,   4).Select  
  oWord.Selection.SelectColumn  
  oWord.Selection.ParagraphFormat.Alignment   =   wdAlignParagraphRight  
  oDoc.Tables(1).Cell(1,   4).Select  
  oWord.Selection.ParagraphFormat.Alignment   =   wdAlignParagraphLeft  
  oWord.Selection.HomeKey   Unit:=wdStory  
   
  'Formating   the   Title  
  oRange.SetRange   0,   Len(sTitle)   -   4  
  With   oRange  
  .Font.Name   =   "宋体"  
  .Font.size   =   16  
  .Font.Bold   =   True  
  .ParagraphFormat.Alignment   =   wdAlignParagraphCenter  
  End   With  
   
  '   Show   Word   to   the   user  
  oWord.Visible   =   True  
   
  If   oldRec   >=   1   Then  
  adc_card.Recordset.MoveFirst  
  adc_card.Recordset.Move   oldRec   -   1  
  End   If  
   
  'CheckBox   on   form   says   "立即打印"  
  If   Check1   Then   oWord.PrintOut  
-------------------------------------------------------------------------------------------
 
  datagrid   导出到   EXCEL  
   
   
  Private   Sub   Command1_Click()  
  Dim   i   As   Integer  
  Dim   j   As   Integer  
  Dim   xlApp   As   New   Excel.Application  
  Dim   xlBook   As   New   Excel.Workbook  
  Dim   xlSheet   As   New   Excel.Worksheet  
  Set   xlApp   =   CreateObject("Excel.Application")  
  xlApp.Visible   =   True  
  Set   xlBook   =   xlApp.Workbooks.add  
  On   Error   Resume   Next  
  Set   xlBook   =   xlApp.Workbooks.Open("d:/text2.xls")  
  Set   xlSheet   =   xlBook.Worksheets(1)  
  For   j   =   0   To   mgrid.Columns.Count   -   1  
  xlSheet.Cells(1,   j   +   1)   =   mgrid.Columns.Item(j).Caption  
  Next   j  
  xlSheet.Cells(6,   1)   =   "i"  
  Adodc1.Recordset.MoveFirst  
  For   i   =   0   To   Adodc1.Recordset.RecordCount   -   1  
  mgrid.Row   =   i  
  For   j   =   0   To   mgrid.Columns.Count   -   1  
  mgrid.Col   =   j  
  'MsgBox   DataGrid1.Text  
   
  If   IsNull(mgrid.Text)   =   False   Then  
  xlSheet.Cells(i   +   2,   j   +   1)   =   mgrid.Text  
  End   If  
  Next   j  
  Next   i  
   
  End   Sub
------------------------------------------------------------------------------------------ 

评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值