从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
|