从access数据库中导出数据到为excel(sql数据库类似):
dim conn as adodb.connection
Dim rs1 As New ADODB.Recordset
dim sql as string
set conn=new adodb.connection
if conn.state<>0 then conn.close
conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\sclsylb.mdb"
sql="SELECT * FROM QS800" 'QS800表你应该很熟悉
if rs1.state<>0 then rs1.close
rs1.cursorlocation=aduserclient
rs1.open sql,conn,1,3
'导出xls表
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
'On Error GoTo OutPutErr
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
Set xlQuery = xlSheet.QueryTables.Add(rs1, 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 = True
xlQuery.Refresh
cmdlg.Flags = 2
cmdlg.Filter = "EXCEL文档(*.xls)"
cmdlg.ShowSave
If cmdlg.FileName <> "" Then
xlApp.DisplayAlerts = False
xlBook.SaveAs FileName:=cmdlg.FileName
If MsgBox("导出成功,是否打开查看?", vbOKCancel, "导出EXCEL") = vbOK Then
xlApp.Workbooks().Open cmdlg.FileName
xlApp.Visible = True
Else
xlApp.Quit
End If
End If
If xlApp <> Null Then Set xlApp = Nothing
set conn=nothing
set rs1=nothing
联系客服