该连接不能用于执行此操作。 vb6 中的此上下文错误可能已关闭或无效

Question

我正在尝试执行将记录集值存储在 sql 数据库中的查询。当我尝试执行时，我收到错误，例如

连接无法用于执行此操作。 vb6 中的此上下文错误可能已关闭或无效。请帮我解决这个问题。

' Write records to Database

    frmDNELoad.lblStatus.Caption = "Loading data into database......"
    Call FindServerConnection_NoMsg

    Dim lngRecCount As Long
    lngRecCount = 0
    rcdDNE.MoveFirst

    Set rcdReclamation = New ADODB.Recordset
    With rcdReclamation
        .ActiveConnection = objConn
        .Source = "insert into t_DATA_DneFrc (RTN, AccountNbr, FirstName, MiddleName, LastName, Amount) values ('" & rcdDNE("RTN") & "', '" & rcdDNE("AccountNbr") & "', '" & rcdDNE("FirstName") & "', '" & rcdDNE("MiddleName") & "', '" & rcdDNE("LastName") & "', '" & rcdDNE("Amount") & "')"
        .CursorType = adOpenDynamic
        .CursorLocation = adUseClient
        .LockType = adLockOptimistic
        .Open cmdCommand
    End With

    Do Until rcdDNE.EOF
        lngRecCount = lngRecCount + 1
        frmDNELoad.lblStatus.Caption = "Adding record " & lngRecCount & " of " & rcdDNE.RecordCount & " to database."
        frmDNELoad.Refresh
        DoEvents
        Call CommitNew
        rcdDNE.MoveNext
    Loop

    frmDNELoad.lblStatus.Caption = "DNE Processing Complete."
    frmDNELoad.Refresh

End Function

Sub CommitNew()
   ' Add records to DneFrc table
    With rcdReclamation
        .Requery
        .AddNew
        .Fields![RTN] = rcdDNE.Fields![RTN]
        .Fields![AccountNbr] = rcdDNE.Fields![AccountNbr]
        .Fields![FirstName] = rcdDNE.Fields![FirstName]
        .Fields![MiddleName] = rcdDNE.Fields![MiddleName]
        .Fields![LastName] = rcdDNE.Fields![LastName]
        .Fields![Amount] = rcdDNE.Fields![Amount]
        .Update

    End With

End Sub

连接代码

Sub InstantiateCommand_SQLText()
    ' Creates a command object to be used when executing SQL statements.
    Set objCommSQLText = New ADODB.Command
    objCommSQLText.ActiveConnection = objConn
    objCommSQLText.CommandType = adCmdText
End Sub

Function FindServerConnection_NoMsg() As String

    Dim rcdClientPaths As ADODB.Recordset
    Dim strDBTemp As String
    Const CLIENT_UPDATE_DIR = "\\PSGSPHX02\NORS\Rs\ClientUpdate\"

    On Error Resume Next
    ' If persisted recordset is not there, try and copy one down from
    ' CLIENT_UPDATE_DIR.  If that can't be found, create a blank one
    ' and ask the user for the server name.
    Set rcdClientPaths = New ADODB.Recordset
    ' Does it already exist locally?
    If FileExists_FullPath(App.Path & "\" & "t_PCD_ServerConnectionList.xml") = False Then
        ' Can it be retrieved from CLIENT_UPDATE_DIR
        If Dir(CLIENT_UPDATE_DIR & "t_PCD_ServerConnectionList.xml")  "" Then
            FileCopy CLIENT_UPDATE_DIR & "t_PCD_ServerConnectionList.xml", App.Path & "\" & "t_PCD_ServerConnectionList.xml"
        Else
            ' Creat a blank one.
            With rcdClientPaths
                .Fields.Append "ServerConnection", adVarChar, 250
                .Fields.Append "Description", adVarChar, 50
                .CursorType = adOpenDynamic
                .LockType = adLockOptimistic
                .CursorLocation = adUseClient
                .Open
                .Save App.Path & "\" & "t_PCD_ServerConnectionList.xml", adPersistXML
                .Close
            End With
        End If
    End If

    ' Open the recordset
    With rcdClientPaths
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .CursorLocation = adUseClient
        .Open App.Path & "\" & "t_PCD_ServerConnectionList.xml", , , , adCmdFile
    End With

    If rcdClientPaths.RecordCount  0 Then
        ' try each one listed
        rcdClientPaths.MoveFirst
        Do Until rcdClientPaths.EOF
            strDBTemp = TryConnection_NoMsg(rcdClientPaths.Fields![serverconnection])
            If strDBTemp  "" Then
                FindServerConnection_NoMsg = strDBTemp
                Exit Function
            End If
            rcdClientPaths.MoveNext
        Loop
        strDBTemp = ""
    End If

    Do While strDBTemp = ""
        If strDBTemp  "" Then
            strDBTemp = TryConnection_NoMsg(strDBTemp)
            If strDBTemp  "" Then
                With rcdClientPaths
                    .AddNew
                    .Fields![serverconnection] = strDBTemp
                    .Update
                    .Save
                End With
                FindServerConnection_NoMsg = strDBTemp
                Exit Function
            End If
        Else
            Exit Function
        End If
    Loop
End Function

Function TryConnection_NoMsg(ByVal SvName As String) As String
    On Error GoTo ErrHandle
    ' If a server was provided, try to open a connection to it.
    Screen.MousePointer = vbHourglass
    Set objConn = New ADODB.Connection
    With objConn
        .CommandTimeout = 30
        .ConnectionTimeout = 30
        .ConnectionString = "Provider=SQLOLEDB.1; Server=" & SvName & "; User ID=RS_Auth; Password=weLcomers_auth; Initial Catalog=NORS" ' Test
        .Open
        .Close
    End With
    Set objConn = Nothing
    TryConnection_NoMsg = SvName
    Screen.MousePointer = vbNormal
    Exit Function

ErrHandle:
    TryConnection_NoMsg = ""
    Set objConn = Nothing
    Screen.MousePointer = vbNormal
    Exit Function

End Function

Answer 1

您已经在 TryConnection_NoMsg 函数中关闭了连接（？）

 With objConn
        .CommandTimeout = 30
        .ConnectionTimeout = 30
        .ConnectionString = "Provider=SQLOLEDB.1; Server=" & SvName & "; Database=NORS; User ID=RS_Auth; Password=weLcomers_auth; Initial Catalog=NORS" ' Test
        .Open
        .Close

Answer 2

我怀疑 FindServerConnection_NoMsg 无法打开连接，并且由于它以 NoMsg 结尾，因此您没有看到有关连接未打开原因的错误。然后您继续使用该连接，而不知道打开失败。

发布 FindServerConnection_NoMsg 的代码。

顺便说一句，你的问题本身应该给你一个线索。它特别指出该连接无法使用，并且可能未打开。这应该告诉您从哪里开始寻找，并且至少告诉您应该将打开连接的代码作为问题的一部分发布。

Answer 3

谢谢大家。我解决了我的问题。这就是我在代码

Dim lngRecCount As Long 中所改变的
lngRecCount = 0
rcdDNE.MoveFirst

 With cmdCommand
    .ActiveConnection = objConn
    .CommandText = "insert into t_DATA_DneFrc (RTN, AccountNbr, FirstName, MiddleName, LastName, Amount) values ('" & rcdDNE("RTN") & "', '" & rcdDNE("AccountNbr") & "', '" & rcdDNE("FirstName") & "', '" & rcdDNE("MiddleName") & "', '" & rcdDNE("LastName") & "', '" & rcdDNE("Amount") & "')"
    .CommandType = adCmdText

End With

Set rcddnefrc = New ADODB.Recordset
With rcddnefrc
    .ActiveConnection = objConn
    .Source = "SELECT * FROM T_DATA_DNEFRC"
    .CursorType = adOpenDynamic
    .CursorLocation = adUseClient
    .LockType = adLockOptimistic
    .Open
End With

Do Until rcdDNE.EOF
    lngRecCount = lngRecCount + 1
    frmDNELoad.lblStatus.Caption = "Adding record " & lngRecCount & " of " & rcdDNE.RecordCount & " to database."
    frmDNELoad.Refresh
    DoEvents
    Call CommitNew
    rcdDNE.MoveNext
Loop

frmDNELoad.lblStatus.Caption = "DNE Processing Complete."
frmDNELoad.Refresh