将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