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