VB在数据库读取数据库写入EXCEL中 第一次可以写入 第二次excel表只可读 求教
Dim conn As New ADODB.ConnectionDim rs As New ADODB.Recordset
Dim sql As String
Dim connstr As String
connstr = "provider=microsoft.jet.oledb.4.0;" & "data source=" & App.Path & "\data.mdb;"
'***********************************************************************************************
Dim Application As Object
Dim WorkBook As Object
Dim Sheet As Object
'***********************************************************************************************
sql = "select * from members"
conn.Open (connstr)
rs.Open sql, conn, 1, 1
If rs.RecordCount = 0 Then
MsgBox "无记录"
rs.Close
conn.Close
Exit Sub
Else
With CommonDialog1
.DialogTitle = "请输入excel名字"
.Filter = "Microsoft Office Excel 工作簿(*.xls)|*.xls"
.ShowSave
End With
If CommonDialog1.FileName = "" Then Exit Sub
If Dir(CommonDialog1.FileName) <> "" Then
MsgBox "文件已经存在,请重新选择!", vbInformation, "提示"
Exit Sub
End If
Set Application = CreateObject("Excel.Application") '建立EXCEL对象
Workbooks.Add
ActiveWorkbook.SaveAs (CommonDialog1.FileName)
Set WorkBook = Application.Workbooks.Open(CommonDialog1.FileName)
Set Sheet = WorkBook.Sheets.Add() '建立一个新表单
For t = 1 To rs.RecordCount
Sheet.Cells(t, 1).Value = rs.Fields(1).Value '向EXCEL里写数据
Sheet.Cells(t, 2).Value = rs.Fields(2).Value '向EXCEL里写数据
Sheet.Cells(t, 3).Value = rs.Fields(3).Value '向EXCEL里写数据
Sheet.Cells(t, 4).Value = rs.Fields(4).Value '向EXCEL里写数据
Sheet.Cells(t, 5).Value = rs.Fields(5).Value '向EXCEL里写数据
Sheet.Cells(t, 6).Value = rs.Fields(6).Value '向EXCEL里写数据
Sheet.Cells(t, 7).Value = rs.Fields(7).Value '向EXCEL里写数据
rs.MoveNext
Next
ActiveWorkbook.Save '保存
Application.Visible = True 'EXCEL使之可见
MsgBox "导出成功"
Set Sheet = Nothing
Set WorkBook = Nothing
Application.Quit
Set Application = Nothing
rs.Close
conn.Close
End If --------------------编程问答-------------------- excel 文件处于打开状态 所以被锁定
后面应该加一个 Workbook.close
中间部分好像也有毛病---这个代码在我的电脑上调试不过去(改了些地方才过去了)
补充：VB , 控件
