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

Question

我正在尝试执行将记录集值存储在 sql db 中的查询。当我尝试执行时，我收到了类似的错误

该连接不能用于执行此操作。在 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

连接代码

子实例化Command_SQLText()
    ' 创建执行 SQL 语句时要使用的命令对象。
    设置 objCommSQLText = New ADODB.Command
    objCommSQLText.ActiveConnection = objConn
    objCommSQLText.CommandType = adCmdText
结束子

函数 FindServerConnection_NoMsg() 作为字符串

    将 rcdClientPaths 调暗为 ADODB.Recordset
    将 strDBTemp 调暗为字符串
    常量 CLIENT_UPDATE_DIR = "\\PSGSPHX02\NORS\Rs\ClientUpdate\"

    出错时继续下一步
    ' 如果持久记录集不存在，请尝试从
    ' CLIENT_UPDATE_DIR。如果找不到，请创建一个空白
    ' 并询问用户服务器名称。
    设置 rcdClientPaths = New ADODB.Recordset
    '它在本地是否已经存在？
    如果 FileExists_FullPath(App.Path & "\" & "t_PCD_ServerConnectionList.xml") = False 那么
        ' 是否可以从 CLIENT_UPDATE_DIR 中检索
        如果 Dir(CLIENT_UPDATE_DIR & "t_PCD_ServerConnectionList.xml") "" 那么
            FileCopy CLIENT_UPDATE_DIR & "t_PCD_ServerConnectionList.xml", App.Path & "\" & "t_PCD_ServerConnectionList.xml"
        别的
            ' 创建一个空白。
            使用 rcdClientPaths
                .Fields.Append "ServerConnection", adVarChar, 250
                .Fields.Append "描述", adVarChar, 50
                .CursorType = adOpenDynamic
                .LockType = adLockOptimistic
                .CursorLocation = adUseClient
                。打开
                .Save App.Path & "\" & "t_PCD_ServerConnectionList.xml", adPersistXML
                。关
            结束于
        万一
    万一

    ' 打开记录集
    使用 rcdClientPaths
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .CursorLocation = adUseClient
        .Open App.Path & "\" & "t_PCD_ServerConnectionList.xml", , , , adCmdFile
    结束于

    如果 rcdClientPaths.RecordCount 0 则
        ' 尝试列出的每一个
        rcdClientPaths.MoveFirst
        直到 rcdClientPaths.EOF
            strDBTemp = TryConnection_NoMsg(rcdClientPaths.Fields![serverconnection])
            如果 strDBTemp "" 那么
                FindServerConnection_NoMsg = strDBTemp
                退出函数
            万一
            rcdClientPaths.MoveNext
        环形
        strDBTemp = ""
    万一

    做而 strDBTemp = ""
        如果 strDBTemp "" 那么
            strDBTemp = TryConnection_NoMsg(strDBTemp)
            如果 strDBTemp "" 那么
                使用 rcdClientPaths
                    。添新
                    .Fields![服务器连接] = strDBTemp
                    。更新
                    。节省
                结束于
                FindServerConnection_NoMsg = strDBTemp
                退出函数
            万一
        别的
            退出函数
        万一
    环形
结束功能

函数 TryConnection_NoMsg(ByVal SvName As String) As String
    出错时转到 ErrHandle
    ' 如果提供了服务器，请尝试打开到它的连接。
    Screen.MousePointer = vbHourglass
    设置 objConn = New ADODB.Connection
    使用 objConn
        .CommandTimeout = 30
        .ConnectionTimeout = 30
        .ConnectionString = "Provider=SQLOLEDB.1; Server=" & SvName & "; User ID=RS_Auth; Password=weLcomers_auth; Initial Catalog=NORS" ' 测试
        。打开
        。关
    结束于
    设置 objConn = 无
    TryConnection_NoMsg = SvName
    Screen.MousePointer = vbNormal
    退出函数

错误句柄：
    TryConnection_NoMsg = ""
    设置 objConn = 无
    Screen.MousePointer = vbNormal
    退出函数

结束功能

score 1 · Accepted Answer

您已经在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

score 0 · Accepted Answer

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

暗淡 lngRecCount 只要 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

score 0 · Accepted Answer

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

贴出代码FindServerConnection_NoMsg。

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

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

3 回答 3

Related

Reference