Excel中访问Access数据库出现Excel强制关闭

bobbyzhang

本人编写数据库访问的VBA程序经验很少，此次因工作上的需要，编写了Excel+Access的一个程序，其中Excel中会多次查询、更新数据库中的数据，因此，我把访问数据库的代码固化在下面的三个过程中。使用过程中发现，有一次Excel执行代码中报警导致Excel强制退出，后续再次访问时，时不时提示连接数据库无效，或者Excel莫名其妙地强制关闭了。经过观察，Excel退出后，Access数据库的那个文件似乎还有进程访问中。

咨询过有其他编程经验的人，怀疑是访问数据库时锁定了数据库，共享出现了问题。但是限于经验的缺乏，我不知道代码哪里出了问题，或者怎么改。请论坛中大侠帮忙看看，先谢谢！

Public Function GetRecordSet(ByRef iSql As String, Optional ByRef iCursorType As ADODB.CursorTypeEnum = adOpenStatic) As ADODB.Recordset              '查询返回一个数据集
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
        
    If iSql = "" Then Set GetRecordSet = Nothing: Exit Function
    Set cnn = GetConnection() ’获取连接，详见中间的那个过程
    If Not cnn Is Nothing Then
        rst.Open iSql, cnn, iCursorType                         Set GetRecordSet = rst
    Else
        GoTo Error_Hanlding
    End If

    Set rst = Nothing
    Set cnn = Nothing
    Exit Function
   
Error_Hanlding:
    MsgBox "获取数据集错误", vbOKOnly + vbCritical, "底层错误"
    Set GetRecordSet = Nothing
End Function

Public Function GetConnection(Optional ByRef iTimeOut As Long = 30) As ADODB.Connection
    '返回一个数据库连接
    Dim cnn As New ADODB.Connection
    Dim strConn As String
    Dim iDataSource As String
    Dim iRange As Range
   
    Set iRange = FindParameter("DataConnection", "DataSourcing", 1)'这是另一个过程函数，主要就是找到保存DataSourcing 的一个单元格
    If Not iRange Is Nothing Then
        iDataSource = iRange.Value'找到这个单元格，则赋值给DataSourcing
    Else
        Set GetConnection = Nothing: Exit Function
    End If
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & iDataSource
    cnn.ConnectionTimeout = iTimeOut
    cnn.Open strConn
    If cnn.State = adStateOpen Then
        Set GetConnection = cnn
    Else
        Set GetConnection = Nothing
    End If
    Set cnn = Nothing
    Exit Function
   
ErrorHanlding:
    MsgBox "数据库连接出现错误！", vbOKOnly + vbCritical, "底层错误！"
    Set GetConnection = Nothing
End Function

Public Function ExecuteSql(ByRef iSql As String, Optional ByRef iRecordCount As Long = 0) As ADODB.Recordset
    '执行无返回值得SQL语句
    Dim cnn As New ADODB.Connection
    Dim errLoop As ADODB.Error

    If iSql = "" Then Set ExecuteSql = Nothing
    Set cnn = GetConnection()
    If Not cnn Is Nothing Then
        Set ExecuteSql = cnn.Execute(iSql, iRecordCount)
    Else
        GoTo Error_Hanlding
    End If
    Set cnn = Nothing
    Exit Function
   
Error_Hanlding:
     If Errors.Count > 0 Then
      For Each errLoop In Errors
         MsgBox "发生错误: " & errLoop.Number & vbCr & _
            errLoop.Description
      Next errLoop
   End If
   Resume Next
    Set ExecuteSql = Nothing
End Function




补充说明：
在GetConnection 和 GetRecordSet 过程中，没有代码关闭Connection和Recordset 连接，不知道是不是问题的根源，但是我尝试在这两个过程里分别增加 cnn.close 和rst.close，调用这两个过程的语句就会出错，提示"对象已经关闭"，没有办法得到正确的结果。

bobbyzhang

有没有大师可以帮忙看看！谢谢啊！

Renco

这怎么看啊。这需要调试，现在你也没告诉我们在哪段就停止了。
最好有附件调试，因为原因有很多，可能程序没问题，是系统问是。