''''

'将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