请问vb6.0 如何把数据库的数据导入excel中，谢谢

Question

请问vb6.0 如何把数据库的数据导入excel中
最好能有例子，越详细越好

Answer 1

使用sql server的bcp工具，效率较高

Answer 2

How To Transfer Data from ADO Data Source to Excel with ADO 
http://support.microsoft.com/kb/295646/EN-US/How to transfer data from an ADO Recordset to Excel with automation:
http://support.microsoft.com/kb/246335/EN-US/Methods for Transferring Data to Excel from Visual Basic:
http://support.microsoft.com/kb/247412/EN-US/都有例子。

Answer 3

可以参考下面这段代码: 引用直接用 ExporToExcel strsql就可以了. strsql="select name as 姓名 from tablename" 
Public Function ExporToExcel(strOpen As String)    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer    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 = Conn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .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"))    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.Refresh    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With
    '这段是对列头的设置
    '    With xlSheet.PageSetup
    '        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
    '        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
    '        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
    '        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
    '        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
    '        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
    '    End With
    '
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = NothingEnd Function

Answer 4

我用Adodc,datagrid,access
Private Sub Command5_Click()
Dim i As Integer, r As Integer, c As Integer '先在工程里引用.EXE11.0,commondialog(cd1)
  Dim newxls As New Excel.Application
  Dim newbook As New Excel.Workbook
  Dim newsheet As New Excel.Worksheet
  Set newbook = newxls.Workbooks.Add   '创建工作簿
  Set newsheet = newbook.Worksheets(1) '创建工作表
  If Sql <> "" Then
    Adodc1.RecordSource = Sql
    Adodc1.Refresh
  End If
  If Adodc1.Recordset.RecordCount > 0 Then
    For i = 0 To DataGrid1.Columns.Count - 1
         newsheet.Cells(1, i + 1) = DataGrid1.Columns(i).Caption '指定表头名称
    Next i
    '指定表格内容
    Adodc1.Recordset.MoveFirst
    Do Until Adodc1.Recordset.EOF
         r = Adodc1.Recordset.AbsolutePosition
         For c = 0 To DataGrid1.Columns.Count - 1
             DataGrid1.Col = c
             newsheet.Cells(r + 1, c + 1) = DataGrid1.Columns(c)
         Next c
         Adodc1.Recordset.MoveNext
    Loop
      
    Dim myval As Long
    myval = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
    If myval = vbYes Then
        Dim lj
        cd1.Filter = "所有文件|*.*"
      cd1.InitDir = App.Path & "\Excel文件\"
      cd1.ShowSave
      If cd1.FileName = "" Then Exit Sub
      lj = cd1.FileName
      On Error GoTo ErrSave
           newsheet.SaveAs lj & ".xls"
       Adodc1.Recordset.MoveFirst
           MsgBox "Excel文件保存成功，位置：" & lj & ".xls", , "提示窗口"      newxls.Quit
ErrSave:
      Exit Sub
      MsgBox Err.Description, , "提示窗口"
      
      Else: Adodc1.Recordset.MoveFirst
    End If
  End If
End sub

Answer 5

5楼的大神，你的那个dim lj后面的cd1是什么呀？

Answer 6

这类代码应该很多，但大多需要做一些修改之后才能用，不妨用F8调试一下！如果想用dao，那么可以看看VB自带的例子visdata，内有详细代码...

Answer 7

PowerQueryRS是查询后的recordset集
Private Sub SQLtoExcel() '.......在excel中显示Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Set xlapp = CreateObject("excel.application")
xlapp.Visible = True '设置EXCEL可见
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
For K = 1 To PowerQueryRS.Fields.Count
xlsheet.Cells(1, K) = PowerQueryRS.Fields(K - 1).Name
Next K
For i = 1 To PowerQueryRS.RecordCount
For J = 0 To PowerQueryRS.Fields.Count
      xlsheet.Cells(i + 1, J + 1) = trim(PowerQueryRS.Fields.Item(J).Value)
Next JPowerQueryRS.MoveNextNext ixlapp.Columns.AutoFit     excel表格单元格宽度随填充的内容变化

Answer 8

还有  vb6.0 ->工程->引用->microsoft excel 11.0... 要勾上 
      vb6.0 ->工程->引用->microsoft ActiveX Data Objects 2.0... 2.8等 随便够一个