求代码！VB 从数据库导出excel

Question

数据库是ACCESS,数据共有19个字段，分别为
日期 Date,编号 long ,收货单位 text(50), 销售订单号 text(50) ,生产订单号 text(50) ,产品名称 text(50) ,卡号 text(50) ,钢号 text(50) ,等级 text(50) ,箱号 text(50),规格 text(50) ,表面 text(50) ,产品标准 text(100) ,计量毛重 text(50) ,计量皮重 text(50) ,计量净重 text(50) ,质量扣重 text(50) ,包装扣重 text(50) ,交货重量 text(50))
要求功能：
1、自动。每隔一天可自动存储导出的excel表格，并且可以自定义存储路径，文件名为当前日期。
2、手动。可自定义选择存储路径及文件名。
求各位大侠给出代码！

Answer 1

自由灵活，所见即所得的表格组件，开发环境下设计表格内容，独有的单据和Excel两种界面风格，可设计出各种类型的界面，配合强劲的打印功能，轻松解决自由界面和报表难题。其显著特性包括：# 提供了单据， Excel ，Grid 三种界面风格。    
# 开发环境下设计表格，所见即所得。    
# 支持数据库和分组。    
# 既可以作为普通表格使用，又可以作为数据感知组件使用，或者两者同时使用。    
# 独特的双数据源连接，轻松实现单记录布局和主从表连接。    
# 除了通过数据集本身的方法来访问数据库的记录之外，还可以通过读取单元格的Text属性来实现，这样就不必在数据集间来回移动记录。    
# 支持unicode文本。    
# 支持缩放打印，多列打印。    
# 支持缩放字体填充。    
# 提供了列排序，移动行列，隐藏行列，增删行列等功能。    
# 提供了 Excel 样式的过滤功能。    
# 方便的查找对话框。    
# 提供了单元格合并，单元格命名，只读单元格，锁定单元格等功能。    
# 提供了列对象，用于控制整列单元格。    
# 支持虚表，公式(包括自定义公式)， RTF 格式文本，Ole 对象和图表。    
# 提供了按钮、下拉框、复选框、单选钮、日期、超链接、数值类等多种输入方式。    
# 支持整形、正整形、负整形、浮点数、正浮点数、负浮点数、百分比，货币等多种输入方式。可自动处理千分位，可设置小数位数。    
# 九种文本和图形对齐方式，还可通过单元格边距控制输出位置。    
# 导入\导出 Excel 文件，相互粘贴数据。    
# 提供了自动调整行高，竖排文本，字体旋转等输出功能。    
# 可以设置单元格掩码，附有掩码编辑器。    
# 设置单元格的 PasswordChar。    
# 单元格内容字符数限制。    
# 单元格支持图形，并且可以拉伸，层叠图形。    
# 可以显示/隐藏单元格的边框、可以设置边框的类型、大小、颜色。    
# 支持单元格斜线。    
# 3D 外观的单元格。    
# 设置单元格的光标和提示。    
# 支持自绘画单元格。    
# 设置固定行和列。    
# 保存到文件和流。    
# 提供了复制/粘贴区域功能。    
# VCL 版本可以插入其它可视 VCL 组件。 http://www.anylib.com

Answer 2

http://www.programfan.com/club/showpost.asp?id=80946&t=o
访问了access后，就可以按你的要求获取数据

Answer 3

我这有个我自己写的报表程序 可以完成你要求的手动操作
要想自动操作的话需要改改代码
http://hexunsoft.cn
网站里有个报表程序

Answer 4

给你一个思路。1. 用文本文件或 .ini 文件保存一个文件路径。如果文件不存在，或者路径错误，则在程序开始运行时，用 CommonDialog 控件要求用户选择路径。
2. 建议保存到 .csv 文件，既快捷，文件又小，而且双击文件名即打开在 Excel 中。Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strHeader As String, i As IntegerSet cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\db1.mdb"
Set rs = cn.Execute("Select * From cell")For i = 0 To rs.Fields.Count - 1
    strHeader = strHeader & "," & rs.Fields(i).Name
Next i
strHeader = Mid(strHeader, 2)Open strBackupPath & "\" & Format(Date, "yyyymmdd") & ".csv" For Output As #1
Print #1, strHeader
Print #1, rs.GetString(, , ",")
Close #1Set rs = Nothing
cn.Close
Set cn = Nothing3. 自定义字段无非是给出一个字段表。你用它替代上面查询语句中的 * 即可。

Answer 5

谢谢你的帮助!我知道怎么连接访问数据库了，可是还不知道怎么将从数据库查询出来的数据保存的EXCEL

Answer 6

把楼上取到的rst,丢到这个函数里Sub CreatexcelFile(ByVal sFileName As String, ByVal rst As ADODB.Recordset)
On Error Resume Next
''    Dim oExcel As Excel.Application
''    Dim oExcelBook As Excel.Workbook
''    Dim oExcelSheet As Excel.Worksheet    Dim oExcel
    Dim oExcelBook
    Dim oExcelSheet
    
    Dim intCol As Long
    Dim intRow As Long
    Dim intRowAs As Long
   
    If rst Is Nothing Then Exit Sub    Set oExcel = CreateObject("Excel.Application")
    Set oExcelBook = oExcel.Workbooks.Add
    Set oExcelSheet = oExcelBook.Worksheets(1)
    
    With rst
        .MoveFirst
        '输出内容
        Do While Not .EOF
            For intCol = 0 To .Fields.Count - 1
                oExcelSheet.Cells(intRow + 1, intCol + 1) = .Fields(intCol).Value
            Next intCol
            .MoveNext
            intRow = intRow + 1
        Loop
    End With
    
    '关闭所有提示
    oExcel.AlertBeforeOverwriting = False
    oExcel.PromptForSummaryInfo = False
    oExcel.ShowStartupDialog = False
        oExcelBook.SaveAs sFileName
    '自动杀掉Excel进程
    'xlAutoOpen=1;xlAutoClose=2
    oExcelBook.RunAutoMacros (1) '运行EXCEL启动宏
    oExcelBook.RunAutoMacros (2) '运行EXCEL关闭宏
    oExcel.Quit    Set oExcel = Nothing
    Set oExcelBook = Nothing
    Set oExcelSheet = Nothing
         
End Sub

Answer 7

一格一格从EXCEL中读记录,再一条条往ACCESS里面写(或者反过来),逻辑上无疑是正确的,但是效率上也是很低的. 
使用以下方法,将可以提高数百倍效率(因为ACCESS本身就直接支持和EXCEL的数据转换,根本不必到自己的程序里绕个大圈子): 
1:工程"引用"里面选中ACCESS对象(就和选中EXCEL对象一样) 
2:大体代码: 
  Dim ACC As New Access.Application 
  ACC.OpenCurrentDatabase DBName '数据库全名(*.mdb) 
  ACC.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, TableName, XLSName, True, SheetName 
'TableName=>数据表名字,XLSName=>Excel文件全名,SheetName=>Excel表的名字 
3:要求:预先根据EXCEL的SHEET字段,在MDB中建立好一个空白的数据表(只有字段名,没有记录) 当然,如果为了程序任意性更大,也可以临时获取EXCEL表的字段名,在ACCESS中建立一个同样结构的空表.看你自己需要. 4:以上代码就和你在ACCESS中用菜单选择导入(导出的话,只要换一个方法而已)一个EXCEL文件是一样的.因此你完全可以在写代码之前先手工做一个试试,看看速度如何. 楼主请仔细查看一下ACCESS对象的方法,和EXCEL对象在很多地方是一样的,摸索+搜索就一定能解决问题.

Answer 8

WallesCai,牛人！
不过TransferSpreadsheet美中不足的是只能导出整个表，要部分数据的话要先建个查询才能做。

Answer 9

为了节约代码  通常这部分的代码 我一般用输出到粘贴板的  要客户自己粘贴下  当然 非要生城EXCEL的话 那就再写段粘贴 的 宏代码  速度奇快 

Answer 10

没想到有这么多的大侠帮忙！谢谢各位了！如果有好的实例最好，这样我就能理解的快点！请大侠提供好的方法的同时给个实例，劳烦了！邮箱：[email protected]

Answer 11

Private Sub Command1_Click()
    Dim xlapp1 As Excel.Application
    Dim xlbook1 As Excel.WorkBook
    Dim xlsheet1 As Excel.Worksheet
    
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    
    cn.CursorLocation = adUseClient
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\Administrator\My Documents\xmbcs\mydb2.mdb;Persist Security Info=False"
    
    rs.Open "select * from f2", cn, adOpenStatic, adLockOptimistic    CommonDialog1.ShowSave
    
    Set xlapp1 = CreateObject("Excel.Application")
    Set xlbook1 = xlapp1.Workbooks.Add
    Set xlsheet1 = xlbook1.Worksheets(1)    For i = 1 To rs.Fields.Count
        Sheet1.Cells(1, i + 1) = rs.Fields(i - 1).Name
    Next i    Sheet1.Range("b2").CopyFromRecordset rs
    
    rs.Close
    Set rs = Nothing
    
    cn.Close
    Set cn = Nothing
    
    xlbook1.SaveAs CommonDialog1.FileName
    WorkBook.Close
    xlapp1.Quit
    Set xlapp1 = NothingEnd Sub

Answer 12

Public Function DbToExcel() As Boolean
Dim sql As String
Dim i
Dim rst As ADODB.Recordset
Dim IRowCount As Integer                '行数
Dim IColCount As Integer                '列数Dim xlApp As New Excel.Application      'excel对象
Dim xlBook As Excel.Workbook            '工作簿对象
Dim xlsheet As Excel.Worksheet          '工作表对象
Dim xlQuery As Excel.QueryTableDbToExcel = False                  '首先赋初值为假
SQL="select 日期 ,编号 ,收货单位, 销售订单号 ,生产订单号 ,产品名称 ,卡号  ,钢号  ,等级 ,箱号 ,规格  ,表面 ,产品标准  ,计量毛重  ,计量皮重  ,计量净重  ,质量扣重  ,包装扣重  ,交货重量  from table "'写一个数据库查询函数 ExecuteSQL
 
    rst=  ExecuteSQL(sql）
   
    If rst.EOF Then
    MsgBox "数据库中没有数据！", vbCritical + vbOKOnly, "提示"
    Exit Function
    End If
   
    
    With rst
       
    IRowCount = .RecordCount
    IColCount = .Fields.Count
    
    End With   Set xlApp = CreateObject("Excel.Application") '创建excel对象
   Set xlBook = Nothing '工作簿
   Set xlsheet = Nothing '工作表
   Set xlBook = xlApp.Workbooks().Add '添加一个工作簿
   Set xlsheet = xlBook.Worksheets("sheet1") '工作表
   xlApp.Visible = True 
       
  With xlQuery
     .FieldNames = True                   '
     .RowNumbers = False                  '设置第一列是否显示序号
     .FillAdjacentFormulas = False
     .PreserveFormatting = True
     .RefreshOnFileOpen = False
     .BackgroundQuery = True
     .RefreshStyle = xlInsertDeleteCells
     .SavePassword = True
     .SaveData = True
     .AdjustColumnWidth = True '使用合适的列宽
     .RefreshPeriod = 0
     .PreserveColumnInfo = True
  End With
  xlQuery.FieldNames = True '设置是否在第一行处显示字段名
xlQuery.RefreshWith xlsheet
.Range(.Cells(1, 1), .Cells(1, IColCount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, IColCount)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(IRowCount + 1, IColCount)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End WithxlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlsheet = Nothing
Set xlQuery = Nothing
     DbToExcel = True
End Function