VB导出EXCEL及ACCESS方法

Public Function ExportToExcel(rs As ADODB.Recordset, title As String, conn As ADODB.Connection)

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 xlSheet = Nothing

Set xlBook = Nothing

Set xlBook = Excel.Workbooks.Add

Set xlSheet = Excel.Worksheets(\"sheet1\")

Set xlQuery = xlSheet.QueryTables.Add(rs, xlSheet.Range(\"a1\"))

xlApp.Visible = True

xlQuery.FieldNames = True

xlQuery.RowNumbers = False

xlQuery.FillAdjacentFormulas = False

xlQuery.PreserveFormatting = True

xlQuery.RefreshOnFileOpen = False

xlQuery.BackgroundQuery = True

xlQuery.RefreshStyle = xlInsertDeleteCells

xlQuery.SavePassword = True

xlQuery.SaveData = True

xlQuery.AdjustColumnWidth = True

xlQuery.RefreshPeriod = 0

xlQuery.PreserveColumnInfo = True

xlQuery.Refresh

xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, rs.Fields.Count)).Font.Name = \"黑体\"

xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(rs.RecordCount, rs.Fields.Count)).Borders.LineStyle = xlContinuous

xlSheet.PageSetup.CenterHeader = \"&\"\"楷体_GB2312,常规\"\"\" & title & \"&\"\"宋体,常规\"

xlSheet.PageSetup.LeftFooter = \"&\"\"楷体_GB2312,常规\"\"&10日期：\" & Date

xlSheet.PageSetup.RightFooter = \"&\"\"楷体_GB2312,常规\"\" &10 第&P页 共&N页\"

xlApp.Application.Visible = True

Set xlApp = Nothing

Set xlBook = Nothing

Set xlQuery = Nothing

End Function

帮忙看下 问题是第一次导出正常 第二次导出就出错 error的description没有任何信息

问题补充 2010-03-29 21:23

第一次导出后我把excel关掉然后再点一次 就看见一闪就不见了 因为用了on error语句 所以跳出来一个错误框 我是在程序里调用这个导出的函数 所以不可能跳过创建的啊

匿名 回答:2 人气:2 解决时间:2010-04-01 18:03

Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim a(100, 100) As String

Private Sub Command2_Click() '读取

Set xlApp = CreateObject(\"Excel.Application\")

Set xlBook = xlApp.Workbooks.Open(\"C:\\a.xls\")

Set xlSheet = xlBook.Worksheets(\"sheet1\")

a(1, 1) = xlSheet.Cells(1, 1)

End Sub

Private Sub Command3_Click() ' 写入

Set xlApp = CreateObject(\"Excel.Application\")

Set xlBook = xlApp.Workbooks.Add(\"C:\\1.xls\")

Set xlSheet = xlBook.Worksheets(\"sheet1\")

xlApp.Visible = False

xlSheet.Cells(1, 1) = 1

xlBook.SaveAs \"C:\\1.xls\"

End Sub

Public Function executesql1(ByVal sql As String) As ADODB.Recordset

Dim cnn As ADODB.Connection

Dim rst As ADODB.Recordset

Dim cmd As String

cmd = \"provider=microsoft.jet.oledb.4.0;\" & \"data source=\" & App.path & \"\\..\\data\\wrwtj.mdb;\"

Set cnn = New ADODB.Connection

Set rst = New ADODB.Recordset

With cnn

.ConnectionString = cmd

.Open

End With

With rst

.Open sql, cnn, adOpenKeyset, adLockOptimistic

Set executesql1 = rst

End With

Set rst = Nothing

Set cnn = Nothing

End Function