我正在尝试执行在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
连接码
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
答案 0 :(得分: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
答案 1 :(得分:0)
我怀疑FindServerConnection_NoMsg
无法打开连接,因为它以NoMsg
结束,您没有看到关于未打开连接的错误。然后,您继续使用连接,而不知道打开失败。
发布FindServerConnection_NoMsg
的代码。
答案 2 :(得分:0)
谢谢大家。我解决了我的问题。这就是我的代码
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