百分求救——把ADO查询出来的记录集导到excel里，或者把一个表导到excel里

http://expert.csdn.net/Expert/topic/1035/1035148.xml?temp=.9380762

Dim sTemp As String
Dim xlApp As Excel.Application
Dim xlwork  As Excel.Workbook
Dim sFileName As String
Dim sFileName1 As StringsFileName = App.path & "\xls\test.xls"
sFileName1 = App.path & "\Temp\test.xls"If Not (xlApp Is Nothing) Then Set xlApp = NothingSet xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        sTemp = Dir(sFileName)

        If sTemp <> "" Then
            xlApp.Workbooks.Open (sFileName)
        Else
            xlApp.Workbooks.Add
        End If
sTemp = Dir(sFileName1)
        If sTemp <> "" Then
            sTemp = Time
            sTemp = Replace(sTemp, ":", ".")
            sFileName1 = App.path & "\Temp\statistics" & sTemp & ".xls"
        End If
        xlApp.Workbooks(1).SaveAs sFileName1
        xlApp.Sheets(1).Select
        xlApp.Sheets(1).Name = "test"

sFileName1 = App.path & "\Temp\statistics" & sTemp & ".xls"
->
sFileName1 = App.path & "\Temp\test" & sTemp & ".xls"

要导入的数据在哪里啊？
我想把一个access表或者是ADO查询出来的数据集放入到excel里去，麻烦给解释一下

xlApp.Range("a1")= rs.Fields(0).Value

Dim xlsApp          As Object
        Dim rstTmp          As ADOR.Recordset
            Set xlsApp = CreateObject("Excel.Application")
            xlsApp.Workbooks.Add (1)
            If rstTmp.RecordCount > 0 Then
                rstTmp.MoveFirst
                xlsApp.ActiveWorkbook.ActiveSheet.Name = "test"
                '保存字段名
                For lngJ = 0 To rstTmp.Fields.Count - 1
                    xlsApp.ActiveSheet.Cells(1, lngJ + 1).Value = rstTmp.Fields(lngJ).Name
                    xlsApp.Range(Chr(lngJ) & 1).AutoOutline
                Next
                xlsApp.Rows(1).Font.ColorIndex = 5
                xlsApp.ActiveSheet.Range("A" & 2).CopyFromRecordset rstTmp, rstTmp.RecordCount, rstTmp.Fields.Count
                xlsApp.Cells.Select
                xlsApp.Cells.EntireColumn.AutoFit
                xlsApp.Range("A1").Select
            End If
            xlsApp.ActiveWorkbook.SaveAs "C:\test.xls"
            xlsApp.Application.Quit
            Set xlsApp = Nothing

---- 微软公司的Office系列办公软件相信已是众所周知，其中Excel强大的统计制表功能、Access功能完备的数据处理能力深受众多用户所喜爱。Visual Bsaic更是微软公司又一有力的产品，它简单易学，在Windows编程中的应用十分广泛。本文通过介绍数据处理及复杂表格的打印，来讨论VB与Excel及Access的结合运用。 ---- 由于笔者所在的公司员工众多，在进行职工养老保险缴费的计算工作时，若使用劳动局编制的软件（用Foxbase编写），无论是在管理或维护方面均显得力不从心。于是在公司领导的强烈要求下，决定由笔者构思重新编制。基本思路是：1.将所有员工资料输入Access进行处理，以便于维护。2.在Excel中预先制成有表头的空表（Access相对欠缺处理复杂表格的能力），对需要进行金额汇总或其他运算的单元格可直接输入公式。3.在VB中编写程序代码，从Access中提取数据填入Excel对应表格相应的单元格，并输出至打印机。 ---- 部分窗体及源程序代码如下： ---- 1．程序主模块 ---- 定义Excel、Access对象变量，显示系统启动画面，进入系统主程序界面。强调一下，在编写程序之前须加入对Excel及Access库函数的引用，具体操作是：选择菜单栏'工程'\'引用…'，将'可使用的引用'列表框内'Microsoft Access 8.0 Object Library'和 'Microsoft Excel 8.0 Object Library'两项前的复选框标为选中，按"确定"返回。 mdsMain.bas
'定义数据库记录集及Excel对象变量
Public ex As New Excel.Application
Public exwbook As Excel.Workbook
Public exsheet As Excel.Worksheet
Public mydatabase As Database
Public myrecordset1 As Recordset
[定义记录集]
……
……
Public Opt As Integer '报表选项
[Opt为frmSelreport.frm返回值]
Public isYN As Boolean
Sub Main()
Load frmSplash
frmSplash.Show
frmSplash.Label2.Caption =
" 系统正在加载Access数据库..."
　　Set mydatabase = OpenDatabase("c:\sbda\sbda.mdb")
Set myrecordset1 = mydatabase.OpenRecordset
("报表打印(一)")
[此处对记录集赋值]
　　……
　　……
frmSplash.Label2.Caption =
" 系统正在加载Excel电子表格..."
Set ex = CreateObject("excel.application")
Set exwbook = ex.Workbooks.Open("c:\sbda\sbda.xls")
Load FrmInput　　　 '将数据输入窗体加载到内存中
Unload frmSplash
Load FrmMain　　　　'将主程序界面加载到内存中
End Sub---- 2．报表打印模块
---- 其中ExcelDoForVB1()是一子程序，由prnProess()调用，作用是从Access中提取所需数据资料，填入Excel对应工作表（Worksheet）的相应单元格（Cells）中，然后打印已填入数据的表格；prnProess()则负责实现对VB通用对话框（Commom Dialog）中打印功能的控制。 mdlPrint.bas
Option Explicit
'定义循环计数变量
Public nRow As Integer, nCol As
Integer, nBtoE As Integer
'定义变量接收打印对话框返回值
Public BeginPage, EndPage, NumCopies
'程序运行时需进行判断的各种标志
Public nflag, Flag, ifNum
'数据记录集中指针移动数
Public PageN As Integer, n As Integer
'bar1为进度条
Public bar1 As ObjectSub prnProess()　　　　　　
'控制通用对话框打印功能
　　Set bar1 = FrmPrint.PgsBar1　'进度条
　　On Error GoTo errhandle:
　　If Flag = 0 Then　　　'当打印对话框中选"全部"时
　　　　Select Case Opt　　'选择需要打印的表格
　　　　　　Case 1
　　　　　　　　nflag = 1
　　　　　　　　myrecordset1.MoveFirst
　　　　　　　　myrecordset1.MovePrevious
　　　　　　　　PageN = 1
　　　　　　　　Do While nflag = 1
　　　　　　　　　　Call ExcelDoForVB1　
'数据填入Excel单元格打印
　　　　　　　　　　PageN = PageN + 1
　　　　　　　　Loop
　　　　　　Case 2
　　　　　　……
　　　　　　……
　　　　End Select
　　Else
　　　　If Flag = 2 Then　　'
当打印对话框中选"页"时
　　　　　　If EndPage - BeginPage = 0 Then
　　　　　　　　ifNum = 0
　　　　　　Else
　　　　　　　　If EndPage - BeginPage > 0 Then
　　　　　　　　　　ifNum = 1
　　　　　　　　Else
　　　　　　　　　　ifNum = 2
　　　　　　　　End If
　　　　　　End If
　　　　　　Select Case ifNum
　　　　　　　　Case 2
　　　　　　　　　　Exit Sub
　　　　　　　　Case 0
　　　　　　　　　　Select Case Opt　　 '
选择需要打印的表格
　　　　　　　　　　　　Case 1
myrecordset1.MoveFirst
n = (BeginPage - 1) *
(49 - 4 + 1) - 1
myrecordset1.Move n
PageN = BeginPage
Call ExcelDoForVB1
　'数据填入Excel单元格并打印
　　　　　　　　　　　　Case 2
　　　　　　　　　　　　……
　　　　　　　　　　　　……
　　　　　　　　　　　　End Select
　　　　　　　　 Case 1
　　　　　　　　　　Select Case Opt　　　
'选择需要打印的表格
　　　　　　　　　　　　Case 1
myrecordset1.MoveFirst
n = (BeginPage - 1) *
(49 - 4 + 1) - 1
myrecordset1.Move n
PageN = BeginPage
For nBtoE = BeginPage To EndPage
　　Call ExcelDoForVB1　
'填入Excel单元格并打印
　　PageN = PageN + 1
Next nBtoE
　　　　　　　　　　　　Case 2
　　　　　　　　　　　　……
　　　　　　　　　　　　……
　　　　　　　　　　　　End Select
　　　　　　End Select
　　　　End If
　　End If
　　FrmMain.Visible = True
　　Exit Sub
errhandle:
　　FrmPrint.Visible = False
FrmMain.Visible = True
End Sub---- 注意，下段仅通过ExcelDoForVB1()对"报表（一）"的处理，来说明数据填入Excel并打印的整个过程。 Sub ExcelDoForVB1()　　　　　 '打印报表（一）
　　FrmPrint.Visible = True
　　Set exsheet = exwbook.Worksheets("sheet1")
　　ex.Sheets("Sheet1").Select
　　ex.Range("A4:U49").Select
　　ex.Selection.ClearContents
　　ex.Range("A4").Select
　　bar1.Min = 0　　　　　　
　　bar1.Max = 45　　　　　
　　For nRow = 4 To 49
　　bar1.Value = nRow - 4　　 '进度显示栏进程
　　　　myrecordset1.MoveNext
　　　　If myrecordset1.EOF Then
　　　　　　nflag = 0
　　　　　　Exit For
　　　　End If
　　　　For nCol = 1 To 21
　　　　　　exsheet.Cells(nRow, nCol) =
myrecordset1.Fields(nCol - 1)
　　　　Next nCol
　　Next nRow
　　exsheet.Cells(52, 21) = "第 " + CStr(PageN) + " 页"
　　FrmPrint.Visible = False
　　bar1.Value = 0
ActiveWindow.SelectedSheets.PrintOut Copies:=NumCopies
End Sub

要保存到EXCEL方法，可利用True DBGrid7.0控件，有一个导出功能；
不过先要对导出的文件定一个文件头，因导出的格式为HTM文件格式，不然有时会出现乱码，这是在很长的实现在摸索出来的。
文件头过程为：
Function WriteExcelFileHead(ByVal vbExceFileName As String) As Boolean
  Dim strHeadString As String
  Dim FSO, xls
  On Error GoTo errWriteExcelFileHead
  strHeadString = "<!DOCTYPE HTML PUBLIC " & Chr(34) & "-//W3C//DTD HTML 4.0 Transitional//EN" & Chr(34) & " > " & vbCrLf
  strHeadString = strHeadString & "<HTML><HEAD>" & vbCrLf
  strHeadString = strHeadString & "<META http-equiv=Content-Type content=" & Chr(34) & "text/html; charset=gb2312" & Chr(34) & ">" & vbCrLf
  strHeadString = strHeadString & "<META content=" & Chr(34) & "MSHTML 6.00.2462.0" & Chr(34) & " name=GENERATOR></HEAD>" & vbCrLf
  strHeadString = strHeadString & "<BODY>" & vbCrLf
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set xls = FSO.CreateTextFile(vbExceFileName, True)
  xls.WriteLine (strHeadString)
  xls.Close
  WriteExcelFileHead = True
ExitFunction:
  Set xls = Nothing
  Set FSO = Nothing
  Exit Function
errWriteExcelFileHead:
  WriteExcelFileHead = False
  GoTo ExitFunction
End Function然后利用TDBGRID7。0控件的导出方法ExportToFile ：
Public Sub ExportToExcel(pDlgFile As CommonDialog, pTDBGrid As TDBGrid)
  On Error GoTo errSaveExcel

  pDlgFile.CancelError = True
  pDlgFile.FilterIndex = 0
  pDlgFile.ShowSave
  Do While Dir(pDlgFile.FileName) <> ""
    If MsgBox(pDlgFile.FileName & " 文件已存在！是否覆盖？", vbYesNo + vbDefaultButton2 + vbQuestion, "文件存在") = vbNo Then
      pDlgFile.ShowSave
    Else
      Kill pDlgFile.FileName
    End If
  Loop
  If Not WriteExcelFileHead(pDlgFile.FileName) Then
    MsgBox "创建文件时失败，请重新命名再试！", vbCritical, "创建文件失败"
    Exit Sub
  End If  pTDBGrid.ExportToFile pDlgFile.FileName, True
‘True 表示在给定的文件尾进行追加操作
‘文件名给定这：.xls，则可以用EXCEL文件打印，并且保持TDBGRID中的所有格式；很好用的，这是我所有程序中调用的两个过程，很方便就可以将满足要求的记录集导出到EXCEL中，以操作；
  Exit Sub
errSaveExcel:
  If Err.Number = 32755 Then Exit Sub
  MsgBox Err.Description, vbCritical, "保存失败"
End Sub‘请一定给分！！！！

加入打印命令按钮(command1)，CAPTION 设为" 生成EXCEL 表
格"，写入下面代码Private Sub command3_Click()
Dim i As Integer
Dim j As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.WorksheetSet xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Set xlBook = xlApp.Workbooks.Add
'On Error Resume Next
Set xlBook = xlApp.Workbooks.Add 'Open("d:\text2.xls")
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Cells(6, 1) = "i"
For i = 0 To gridrow
grid1.Row = i
For j = 0 To 6
Grid1.Col = jIf IsNull(Grid1.Text) = False Then
xlSheet.Cells(i + 5, j + 1) = Grid1.Text
End If
Next j
Next i
Exit Sub

实在不好意思，我必须问一个十分低级的问题，我现在要使用excel控件，必须先注册吗？我在project->reference里加入了不可以吗？必须加到component里去吗？我一加，系统就提示我说未注册，如果要注册的话，将如何注册啊？麻烦务必帮忙，要多少分多行！

regsvr32 *.ocx 或 *.dll

access to execel
1.增加以下控件
    button     4个，名字按代码
    texbox  3个  ，  最后一个多行
2.增加以下代码
Option Explicit
Dim strDBName As String
Dim exl As Excel.Application
Dim eWorkBook As New Excel.Workbook
Dim eWorkSheet As New Excel.WorksheetPrivate Sub cmdClose_Click()
    Unload Me
End SubPrivate Sub cmdConvert_Click()
    Dim cn As New ADODB.Connection
    Dim oSchema As ADODB.Recordset
    Dim rs As New ADODB.Recordset
    Dim intFldCnt As Integer
    Dim i As Integer
    Dim j As Integer
    Dim sngColWid As Single

    On Error GoTo ExcelErr
    Screen.MousePointer = vbHourglass

    If strDBName = "" Then
        MsgBox "Please select a database"
        Exit Sub
    End If

    If txtEXL.Text = "" Then
        MsgBox "Please select a name for the new spreadsheet."
        Exit Sub
    End If
    txtResults.Text = ""
    txtResults.Text = "Opening Database..." & vbCrLf

    cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBName & ";Persist Security Info=False"
    cn.Open (strDBName)
    Set oSchema = cn.OpenSchema(adSchemaTables)

    Set exl = New Excel.Application
    Set eWorkBook = exl.Workbooks.Add
    txtResults.Text = txtResults.Text & "Creating Workbook..." & vbCrLf

    Do Until oSchema.EOF
        If InStr(oSchema!table_name, "MSys") = 0 Then
            Set eWorkSheet = eWorkBook.Worksheets.Add
            txtResults.Text = txtResults.Text & "Creating Worksheet " & oSchema!table_name & "..." & vbCrLf
            If InStr(oSchema!table_name, "/") <> 0 Then
                eWorkSheet.Name = Replace(oSchema!table_name, "/", "-")
            Else
                eWorkSheet.Name = oSchema!table_name
            End If

            rs.Open "select * from [" & oSchema!table_name & "]", cn
            intFldCnt = rs.Fields.Count - 1
            txtResults.Text = txtResults.Text & "Adding Column Headers..." & vbCrLf
            For i = 1 To intFldCnt
                eWorkSheet.Cells(1, i) = rs.Fields(i).Name
                If TextWidth(rs.Fields(i).Name) > sngColWid Then
                    sngColWid = TextWidth(rs.Fields(i).Name)
                End If
            Next i
            eWorkSheet.Range("A1", "Z1").Font.Bold = True
            eWorkSheet.Range("A1", "Z1").Font.Underline = True

            j = 2
            txtResults.Text = txtResults.Text & "Adding Data from Database Table " & oSchema!table_name & "..." & vbCrLf
            Do Until rs.EOF
                For i = 1 To intFldCnt
                    eWorkSheet.Cells(j, i) = rs.Fields(i).Value
                Next i
                j = j + 1
                rs.MoveNext
            Loop
            rs.Close
            Debug.Print oSchema!table_name
        End If
        oSchema.MoveNext
    Loop
    txtResults.Text = txtResults.Text & "Done!!!!"
    eWorkBook.SaveAs txtEXL.Text
    Screen.MousePointer = vbNormal
    Exit Sub

ExcelErr:
    Screen.MousePointer = vbNormal
    Select Case Err.Number
        Case 1004
            Resume Next
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
    End SelectEnd SubPrivate Sub cmdDB_Click()
    cdg1.Filter = "MS Access Database (*.mdb)|*.mdb"
    cdg1.ShowOpen
    strDBName = cdg1.FileName
    txtDB.Text = strDBName
End SubPrivate Sub cmdEXL_Click()
    cdg1.Filter = "MS Excel Spreadsheet (*.xls)|*.xls"
    cdg1.ShowOpen
    txtEXL.Text = cdg1.FileNameEnd SubPrivate Sub Form_Unload(Cancel As Integer)

    On Error Resume Next

    exl.Application.Quit

End Sub

调试易

百分求救——把ADO查询出来的记录集导到excel里，或者把一个表导到excel里

解决方案 »