将ACCESS 的数据库中的表的文件 导出了EXCEL格式

将ACCESS 的数据库中的表的文件 导出了EXCEL格式

''''
'将ACCESS数据库中的某个表的信息 导出为EXCEL 文件格式
'srcfName ACCESS 数据库文件路径
'desfName  excel 文件路径
Public Function ExporToExcel(sqlstr As String, srcfName As String, desfName As String)
    On Error Resume Next
    Dim k As Long

    Dim dbCnn As New ADODB.Connection

    Dim Irowcount As Integer
    Dim Icolcount As Integer

    dbCnn.Provider = "Microsoft.JET.OLEDB.4.0"
    dbCnn.Properties("Data Source") = srcfName
    dbCnn.Properties("Persist Security Info") = False


    dbCnn.Open
    
    
    Dim Rs_Data As New ADODB.Recordset

    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = dbCnn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = sqlstr
        .Open
    End With

    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox (srcfName + "没有记录!")
            
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.count
    End With

    Dim f As Integer
    Dim i As Long

    Dim ReadData As String

    Dim tmpStr As String
    Dim SplitCode As String

    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().add
    '            Set xlSheet = xlBook.Worksheets("sheet1")
    Set xlSheet = xlBook.Worksheets(1)
    xlApp.Visible = False

    '添加查询语句，导入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 = CBool(GetIniStr("设定选项", "是否导出标题", App.Path & "\Conn.ini"))     '显示字段名
    xlQuery.Refresh

    
    xlBook.SaveAs desfName
    xlApp.Application.Visible = False
    
    Set xlBook = Nothing
    Set xlSheet = Nothing
    xlApp.Quit
    Set xlApp = Nothing                            '"交还控制给Excel

End Function