使用ADOX创建Excel文件

Excel 2008-01-06 01:58:54 阅读1 评论0 字号：大中小订阅

'**************************************
' 函数名: SaveRecordsetAsExcelFile
' 功   能:这个示例主要演示怎样使用 ADOX把数据导入到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

本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。