'**************************************
' 函數(shù)名: SaveRecordsetAsExcelFile
' 功   能:這個示例主要演示怎樣使用 ADOX把數(shù)據(jù)導(dǎo)入到Excel中去,使用ADO和 ADOX比較快速.
' 記住不要忘記在工程中引用 Microsoft ADO 2.8 和 ADOX 2.8 庫
'**************************************

Public Function SaveRecordsetAsExcelFile(ByRef SourceRecordset As ADODB.Recordset, _
    ByVal ExcelFileName As String, _
    ByVal WorksheetName As String) As Boolean
        
    Dim cnnExcel As ADODB.Connection
    Dim catExcel As ADOX.Catalog
    Dim tblWorksheet As ADOX.Table
    Dim rstExcelData As ADODB.Recordset
    Dim fldColumnHeader As ADODB.Field
    Dim strWkshtName As String
    On Error Goto EH_SaveRecordsetAsExcelFile

    '建立 Excel 文件和 worksheet
    Set cnnExcel = New ADODB.Connection
    Set catExcel = New ADOX.Catalog
    Set tblWorksheet = New ADOX.Table
    cnnExcel.CursorLocation = adUseClient
    cnnExcel.Provider = "Microsoft.Jet.OLEDB.4.0"
    cnnExcel.Properties("Extended Properties") = "Excel 8.0"
    cnnExcel.Open "Data Source = " & ExcelFileName
    Set catExcel.ActiveConnection = cnnExcel
    tblWorksheet.Name = WorksheetName


    For Each fldColumnHeader In SourceRecordset.Fields
        tblWorksheet.Columns.Append fldColumnHeader.Name, fldColumnHeader.Type
    Next 'fldColumnHeader
    catExcel.Tables.Append tblWorksheet
    Set tblWorksheet = Nothing
    Set catExcel = Nothing
    Set cnnExcel = Nothing
    'Fill worksheet with data
    Set cnnExcel = New ADODB.Connection
    Set rstExcelData = New ADODB.Recordset


    With cnnExcel
        .CursorLocation = adUseClient
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties") = "Excel 8.0"
        .Open ExcelFileName
        strWkshtName = "[" & WorksheetName & "$]"


        With rstExcelData
            Set .ActiveConnection = cnnExcel
            .CursorLocation = adUseClient
            .CursorType = adOpenDynamic
            .LockType = adLockOptimistic
            .Source = strWkshtName
            .Open
        End With 'rstExcelData


        With SourceRecordset
            .MoveFirst
            Do While Not .EOF
                rstExcelData.AddNew

                For Each fldColumnHeader In .Fields
                    rstExcelData.Fields(fldColumnHeader.Name) = fldColumnHeader 'insert value
                Next 'fldColumnHeader
                rstExcelData.Update
                .MoveNext
            Loop
        End With 'SourceRecordset
        .Close 'cnnExcel
    End With 'cnnExcel

    Set cnnExcel = Nothing
    Set rstExcelData = Nothing
    Set fldColumnHeader = Nothing
    SaveRecordsetAsExcelFile = True
    Exit Function

    EH_SaveRecordsetAsExcelFile:
    SaveRecordsetAsExcelFile = False
    Set tblWorksheet = Nothing
    Set catExcel = Nothing
    Set cnnExcel = Nothing
    Set rstExcelData = Nothing
    Set fldColumnHeader = Nothing
End Function