怎样把一个VB6.0中的结果集，绑定到Excel中？

Question

怎样把一个VB6.0中的结果集，绑定到Excel中？
给个例子看看,谢谢

Answer 1

'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 参数：rs 记录集 strDestination文件名
'* 返回值：
'* 时间：20031015
'*********************************************************Public Function ExporToExcel(rs As Recordset, strDestination As String) As Integer'    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
    Dim fso As New FileSystemObject
    
    If fso.FileExists(App.Path + "\" + strDestination) Then
    
        
    End If
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
'    Set xlBook = xlApp.Workbooks.Open(App.Path + "\" + "temp.xls")
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = False
    
    '添加查询语句，导入EXCEL数据
    
    Set xlQuery = xlSheet.QueryTables.Add(rs, 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
    
'    xlApp.Application.Visible = True
    xlSheet.SaveAs (App.Path + "\" + strDestination)
    xlQuery.Delete
'    xlBook.Close
    Set xlQuery = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing  
End Function

Answer 2

'下面单个添加的方法。
Sub getSQL(ByVal strSQL As String)
    Dim rst As New adodb.Recordset
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    Dim recArray As Variant
    Dim strDB As String
    Dim fldCount As Integer
    Dim recCount As Long
    Dim iCol As Integer
    Dim iRow As Integer
    Set rst = CreateObject("ADODB.Recordset")
    rst.Open strSQL, cn, 3, 1
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("sheet1")
    xlApp.Visible = True
    xlApp.UserControl = True
    fldCount = rst.Fields.Count
    For iCol = 1 To fldCount
        xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
    Next
        
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        xlWs.Cells(2, 1).CopyFromRecordset rst
    Else
        recArray = rst.GetRows
        recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
        For iCol = 0 To fldCount - 1
            For iRow = 0 To recCount - 1
                If IsDate(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = Format(recArray(iCol, iRow))
                ElseIf IsArray(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = "Array Field"
                End If
            Next iRow 'next record
        Next iCol 'next field
        xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
    End If
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit
    rst.Close
End SubFunction TransposeDim(v As Variant) As Variant
    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant
    
    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)
    
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X
    
    TransposeDim = tempArrayEnd Function