[已解决]EXCEL+ACCESS记录添加问题!

hrq145 · 发表于 2013-5-10 15:21

hwc2ycy 发表于 2013-5-10 15:12

能上传附件吗

hwc2ycy · 发表于 2013-5-10 15:24

再完善了下。

Option Explicit
Const adUseClient = 3
Const adModeShareDenyWrite = 8
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object, AdoRst As Object
Function OpenConnect(strFullname) As Boolean
Dim StrConn$
On Error GoTo ErrorHandler
If AdoConn Is Nothing Then
Set AdoConn = CreateObject("ADODB.Connection")
Else
OpenConnect = True
Exit Function
End If
Select Case Application.Version
Case Is = "14.0":
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
strFullname & "';"
Case Is = "12.0"
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
strFullname & "';"
Case Else
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFullname & "';"
End Select
With AdoConn
.CommandTimeout = 5
.ConnectionTimeout = 5
.CursorLocation = adUseClient
.Mode = adModeReadWrite
.ConnectionString = StrConn
.Open
End With
OpenConnect = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & _
Err.Description
Set AdoRst = Nothing
Set AdoConn = Nothing
End Function
Sub 写入ACC()
Dim strDatabase$
Dim strSQL$
On Error GoTo ErrorHandler
strDatabase = ThisWorkbook.Path & Application.PathSeparator & "三车间数据库.mdb"
If Not OpenConnect(strDatabase) Then
MsgBox "访问 " & strDatabase & " 失败" & vbCrLf & _
"确定退出", vbCritical + vbOKOnly
Exit Sub
End If
If Len(Range("b4")) = 0 Or Len(Range("b7").Value) = 0 Then
MsgBox "B4,B7单元格为必填字段"
Exit Sub
End If
Dim arr
Dim i As Byte
arr = Range("a3:b11")
Set AdoRst = CreateObject("adodb.recordset")
strSQL = "select * from 记录库 where 批号=" & Range("b4").Value
AdoRst.Open strSQL, AdoConn, 2, 3
With AdoRst
If .RecordCount > 0 Then
If MsgBox("批号已经重复" & vbCrLf & _
"确认覆盖记录？", vbCritical + vbOKCancel) = vbOK Then
For i = LBound(arr) To UBound(arr)
.Fields(arr(i, 1)) = arr(i, 2)
Next
Else
Exit Sub
End If
Else
.AddNew
For i = LBound(arr) To UBound(arr)
.Fields(arr(i, 1)) = arr(i, 2)
Next
End If
.Update
MsgBox "添加完成"
End With
Set AdoRst = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & _
Err.Description
End Sub
Sub 读取ACC()
Dim strDatabase$
Dim strSQL$
On Error GoTo ErrorHandler
strDatabase = ThisWorkbook.Path & Application.PathSeparator & "三车间数据库.mdb"
If Not OpenConnect(strDatabase) Then
MsgBox "访问 " & strDatabase & " 失败" & vbCrLf & _
"确定退出", vbCritical + vbOKOnly
Exit Sub
End If
If Len(Range("b4")) = 0 Then
MsgBox "B4单元格为必填字段"
Exit Sub
End If
Dim arr
Dim i As Byte
arr = Range("a3:b11")
Set AdoRst = CreateObject("adodb.recordset")
strSQL = "select * from 记录库 where 批号=" & Range("b4").Value
AdoRst.Open strSQL, AdoConn ', 2, 3
Application.ScreenUpdating = False
With AdoRst
If .RecordCount > 0 Then
For i = LBound(arr) To UBound(arr)
arr(i, 2) = .Fields(arr(i, 1))
Next
Range("a3").Resize(UBound(arr), UBound(arr, 2)).Value = arr
MsgBox "完成"
Else
MsgBox "查找不到批号 " & Range("b4").Value & " 的记录"
Application.ScreenUpdating = False
Range("b3:b11").ClearContents
End If
End With
Set AdoRst = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & _
Err.Description
End Sub
Sub 关闭连接()
If Not AdoConn Is Nothing Then
AdoConn.Close
Set AdoConn = Nothing
MsgBox "连接关闭"
End If
End Sub

复制代码

hwc2ycy · 发表于 2013-5-10 15:25

生产登记.rar (16.82 KB, 下载次数: 25)

hrq145 · 发表于 2013-5-10 15:33

hwc2ycy 发表于 2013-5-10 15:25

为什么我把数据库放在一起，还是找不到数据库呢

hwc2ycy · 发表于 2013-5-10 15:43

文件名没改吧。
用的什么版本。

hrq145 · 发表于 2013-5-10 15:45

没改 2003版

hwc2ycy · 发表于 2013-5-10 15:50

hrq145 发表于 2013-5-10 15:33
为什么我把数据库放在一起，还是找不到数据库呢

你用的什么版本？
另外，实际使用的时候数据库的文件名呢。
最好截图。

我是用10测试的，没有问题。

hrq145 · 发表于 2013-5-10 15:58

hwc2ycy 发表于 2013-5-10 15:50
你用的什么版本？
另外，实际使用的时候数据库的文件名呢。
最好截图。

hwc2ycy · 发表于 2013-5-10 16:12

你数据库存的图标不对啊。是不是没有扩展名啊。
你把数据库改下名三车间数据库.mdb

hrq145 · 发表于 2013-5-10 16:28

hwc2ycy 发表于 2013-5-10 16:12
你数据库存的图标不对啊。是不是没有扩展名啊。
你把数据库改下名三车间数据库.mdb

改了，还不行啊

		自动登录	找回密码
密码			注册