在执行包含大量数据的存储过程时，我收到一个错误"Object was open"。此过程在SQL 2005上的VB 6.00应用程序中运行。在SQL中运行脚本时，没有问题
rs.Open cmd, Options:=adCmdStoredProc
重要提示：此错误仅发生在大量数据中。阈值级别大约是250000行数据。如果检索到的数据量超过这个数量，就会发生错误。如果少，那么就没有问题。
任何建议都将是伟大的
感谢
尝试使用其他游标类型。在连接对象上，尝试从adUseClient切换到adUseServer，反之亦然。
rs.Open cmd, , adOpenStatic, adLockReadOnly, Options:=adCmdStoredProc
尝试使用此模块，它可以帮助您避免在SQL过程中使用recordSet。
注意请使用您自己的连接字符串来替换我的连接字符串。我的代码是为访问数据库而设计的，数据库文件以".mdb"结尾
Option Explicit
'//////////////////////////////////////////////////////////////////////////////
'@@summary
'@@require
'---Class:CHashTable.cls
'---Import:Microsoft ActiveX Data Objects 2.8 Library
'@@reference
'@@license
'@@author sunsoft
'@@create
'@@modify
'---20160812:create this class
'//////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////
'//
'// Public Declare
'//
'//////////////////////////////////////////////////////////////////////////////
'------------------------------------------------------------------------------
' Interface
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Public Const
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Public DataType
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Public Variable
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Public API
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Event Declare
'------------------------------------------------------------------------------
'//////////////////////////////////////////////////////////////////////////////
'//
'// Private Declare
'//
'//////////////////////////////////////////////////////////////////////////////
'------------------------------------------------------------------------------
' Private Const
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Private DataType
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Private Variable
'------------------------------------------------------------------------------
Private m_Conn As ADODB.Connection
Private m_Command As ADODB.Command
Private m_ConnString As String
Private m_FilePath As String
Private m_AutoConnect As Boolean
'------------------------------------------------------------------------------
' Property Variable
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Private API
'------------------------------------------------------------------------------
'//////////////////////////////////////////////////////////////////////////////
'//
'// Class
'//
'//////////////////////////////////////////////////////////////////////////////
'------------------------------------------------------------------------------
' Initialize
'------------------------------------------------------------------------------
Private Sub Class_Initialize()
m_ConnString = ""
m_FilePath = ""
m_AutoConnect = True
End Sub
'------------------------------------------------------------------------------
' Terminate
'------------------------------------------------------------------------------
Private Sub Class_Terminate()
Set m_Conn = Nothing
Set m_Command = Nothing
End Sub
'//////////////////////////////////////////////////////////////////////////////
'//
'// Events
'//
'//////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////
'//
'// Private Property
'//
'//////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////
'//
'// Private Methods
'//
'//////////////////////////////////////////////////////////////////////////////
Private Sub OpenConn()
Set m_Conn = New ADODB.Connection
m_Conn.CursorLocation = adUseClient
m_Conn.Open ConnectionString
End Sub
Private Sub CloseConn()
m_Conn.Close
Set m_Conn = Nothing
End Sub
Private Function m_ApostropheCount(ByVal SQL As String) As Long
'count number of "'"
m_ApostropheCount = Len(SQL) - Len(Replace(SQL, "'", ""))
End Function
Private Function m_ProcessNameParams(mSQL As String, mDic As CHashTable, mParams() As Variant) As Boolean
Dim mNewSql As String, mWord As String, mFieldName As String
Dim mParamCount As Long, i As Long, comaCount As Long
Dim mBeginParam As Boolean
If m_ApostropheCount(mSQL) Mod 2 = 1 Then
Err.Raise 110000000, "Symbal "" '"" must be in pairs,please check SQL statement"
End If
'init mDic
mBeginParam = False
mFieldName = ""
mParamCount = 0
For i = 1 To Len(mSQL)
mWord = Mid(mSQL, i, 1)
Select Case mWord
Case " ", ",", ")"
mNewSql = mNewSql & mWord
If mBeginParam Then
ReDim Preserve mParams(mParamCount)
mParams(mParamCount) = mDic.Item(mFieldName)
mFieldName = ""
mParamCount = mParamCount + 1
End If
mBeginParam = False
Case "'"
comaCount = comaCount + 1
mNewSql = mNewSql & mWord
Case "@"
If comaCount Mod 2 = 0 Then
mBeginParam = True
mNewSql = mNewSql & "?"
Else
'odd number of "'" means that "@" is only string of content
mNewSql = mNewSql & mWord
End If
Case Else
If mBeginParam = False Then
mNewSql = mNewSql & mWord
Else
mFieldName = mFieldName & mWord
End If
End Select
Next i
'all done but check last word for that last word maybe param
If mFieldName <> "" Then
ReDim Preserve mParams(mParamCount)
mParams(mParamCount) = mDic.Item(mFieldName)
mFieldName = ""
End If
'return
mSQL = mNewSql
m_ProcessNameParams = True
End Function
Private Function m_GetVarType(ByRef Value As Variant) As ADODB.DataTypeEnum
Select Case VarType(Value)
Case VbVarType.vbString
m_GetVarType = ADODB.DataTypeEnum.adVarWChar
Case VbVarType.vbInteger
m_GetVarType = ADODB.DataTypeEnum.adSmallInt
Case VbVarType.vbBoolean
m_GetVarType = ADODB.DataTypeEnum.adBoolean
Case VbVarType.vbCurrency
m_GetVarType = ADODB.DataTypeEnum.adCurrency
Case VbVarType.vbDate
m_GetVarType = ADODB.DataTypeEnum.adDate
Case 8209
m_GetVarType = ADODB.DataTypeEnum.adLongVarBinary
Case Else
m_GetVarType = ADODB.DataTypeEnum.adVariant
End Select
End Function
'//////////////////////////////////////////////////////////////////////////////
'//
'// Inherit
'//
'//////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////
'//
'// Public Property
'//
'//////////////////////////////////////////////////////////////////////////////
Public Property Get ConnectionString() As String
ConnectionString = m_ConnString
End Property
Public Property Let ConnectionString(ByVal vNewValue As String)
m_ConnString = vNewValue
End Property
Public Property Get IsReady() As Boolean
IsReady = IIf(Len(ConnectionString) > 0, True, False)
End Property
'//////////////////////////////////////////////////////////////////////////////
'//
'// Public Methods
'//
'//////////////////////////////////////////////////////////////////////////////
'---------------------Data Base Connection
Public Function DbConnFromFile(ByVal filePath As String) As ADODB.Connection
Dim mConn As New ADODB.Connection
mConn.CursorLocation = adUseClient
mConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & filePath & ";"
Set DbConnFromFile = mConn
End Function
Public Sub SetConnToFile(ByVal filePath As String)
m_ConnString = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & filePath & ";"
End Sub
Public Sub SetConnToAccdb(ByVal filePath As String)
m_ConnString = "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & filePath & ";Persist Security Info=False"
End Sub
Public Sub OpenDB()
m_AutoConnect = False
Call OpenConn
End Sub
Public Sub CloseDB()
m_AutoConnect = True
Call CloseConn
End Sub
'---------------------Querys
Public Function ExecQuery(ByVal SQL As String) As ADODB.Recordset
Dim mRes As New ADODB.Recordset
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
Set mRes = m_Command.Execute()
'disconnect from database
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
Set ExecQuery = mRes
Set m_Command = Nothing
End Function
Public Function ExecParamQuery(ByVal SQL As String, _
ParamArray Params()) As ADODB.Recordset
Dim mRes As ADODB.Recordset
Dim mParamArr As Variant, mParam As Variant
Dim i As Long
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
m_Command.CommandType = adCmdText
mParamArr = Params
If VarType(Params(0)) = 8204 Then
mParamArr = Params(0)
End If
With m_Command
For Each mParam In mParamArr
Dim Para As ADODB.Parameter
Set Para = .CreateParameter(CStr(i), m_GetVarType(mParam), adParamInput, LenB(mParam))
Para.Value = mParam
If VarType(mParam) = vbEmpty Then
Para.size = 1
ElseIf VarType(mParam) = vbString Then
If LenB(mParam) = 0 Then
Para.size = 1
End If
End If
.Parameters.Append Para
Next
End With
Set mRes = m_Command.Execute()
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
Set ExecParamQuery = mRes
Set m_Command = Nothing
End Function
Public Function ExecNamedQuery(ByVal SQL As String, HashedParams As CHashTable) As ADODB.Recordset
Dim mParams() As Variant
m_ProcessNameParams SQL, HashedParams, mParams
Set ExecNamedQuery = ExecParamQuery(SQL, mParams)
End Function
Public Function ExecNonQuery(ByVal SQL As String) As Long
Dim affectedRows As Long
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
m_Command.CommandType = adCmdText
m_Command.Execute affectedRows
If m_AutoConnect Then
Call CloseConn
End If
Set m_Command = Nothing
ExecNonQuery = affectedRows
End Function
Public Function ExecParamNonQuery(ByVal SQL As String, ParamArray Params()) As Long
Dim i As Long, affectedRows As Long
Dim mParamArr As Variant, mParam As Variant
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
m_Command.CommandType = adCmdText
mParamArr = Params
If VarType(Params(0)) = 8204 Then
mParamArr = Params(0)
End If
With m_Command
For Each mParam In mParamArr
Dim Para As ADODB.Parameter
Set Para = .CreateParameter(CStr(i), m_GetVarType(mParam), adParamInput, LenB(mParam))
Para.Value = mParam
If VarType(mParam) = vbEmpty Then
Para.size = 1
ElseIf VarType(mParam) = vbString Then
If LenB(mParam) = 0 Then
Para.size = 1
End If
End If
.Parameters.Append Para
Next
End With
m_Command.Execute affectedRows
If m_AutoConnect Then
Call CloseConn
End If
Set m_Command = Nothing
ExecParamNonQuery = affectedRows
End Function
Public Function ExecNamedNonQuery(ByVal SQL As String, HashedParams As CHashTable) As Long
Dim mParams() As Variant
m_ProcessNameParams SQL, HashedParams, mParams
ExecNamedNonQuery = ExecParamNonQuery(SQL, mParams)
End Function
Public Function ExecCreate(ByVal SQL As String) As Variant
Dim mRes As ADODB.Recordset
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
m_Command.CommandType = adCmdText
m_Command.Execute
m_Command.CommandText = "SELECT @@identity"
Set mRes = m_Command.Execute
If mRes.RecordCount > 0 Then
ExecCreate = mRes.Fields(0).Value
Else
ExecCreate = Empty
End If
If m_AutoConnect Then
Call CloseConn
End If
Set m_Command = Nothing
Set mRes = Nothing
End Function
Public Function ExecParamCreate(ByVal SQL As String, ParamArray Params()) As Variant
Dim mParamArr As Variant, mParam As Variant
Dim mRes As ADODB.Recordset
Dim i As Long
Set m_Command = New ADODB.Command
If m_AutoConnect Then
Call OpenConn
End If
m_Command.ActiveConnection = m_Conn
m_Command.CommandText = SQL
m_Command.CommandType = adCmdText
mParamArr = Params
If VarType(Params(0)) = 8204 Then
mParamArr = Params(0)
End If
With m_Command
For Each mParam In mParamArr
Dim Para As ADODB.Parameter
Set Para = .CreateParameter(CStr(i), m_GetVarType(mParam), adParamInput, LenB(mParam))
Para.Value = mParam
If VarType(mParam) = vbEmpty Then
Para.size = 1
ElseIf VarType(mParam) = vbString Then
If LenB(mParam) = 0 Then
Para.size = 1
End If
End If
.Parameters.Append Para
Next
End With
m_Command.Execute
m_Command.CommandText = "SELECT @@identity"
Set mRes = m_Command.Execute
If mRes.RecordCount > 0 Then
ExecParamCreate = mRes.Fields(0).Value
Else
ExecParamCreate = Empty
End If
If m_AutoConnect Then
Call CloseConn
End If
Set m_Command = Nothing
Set mRes = Nothing
End Function
Public Function ExecNamedCreate(ByVal SQL As String, HashedParams As CHashTable) As Variant
Dim mParams() As Variant
m_ProcessNameParams SQL, HashedParams, mParams
ExecNamedCreate = ExecParamCreate(SQL, mParams)
End Function
Public Function ExecScalar(ByVal SQL As String) As Variant
Dim mRes As ADODB.Recordset
Set mRes = ExecQuery(SQL)
If mRes.RecordCount <= 0 Then
ExecScalar = Empty
Else
ExecScalar = mRes.Fields(0).Value
End If
Set mRes = Nothing
End Function
Public Function ExecParamScalar(ByVal SQL As String, _
ParamArray Params()) As Variant
Dim mRes As ADODB.Recordset
If VarType(Params(0)) = 8204 Then
Params = Params(0)
End If
Set mRes = ExecParamQuery(SQL, Params)
If mRes.RecordCount <= 0 Then
Set ExecParamScalar = Nothing
Else
ExecParamScalar = mRes.Fields(0).Value
End If
Set mRes = Nothing
End Function
Public Function ExecNamedScalar(ByVal SQL As String, HashedParams As CHashTable) As Variant
Dim mParams() As Variant
m_ProcessNameParams SQL, HashedParams, mParams
ExecNamedScalar = ExecParamScalar(SQL, mParams)
End Function
'---------------------Table Structure
Public Function Tables() As ADODB.Recordset
Dim mRes As ADODB.Recordset
If m_AutoConnect Then
Call OpenConn
End If
Set mRes = m_Conn.OpenSchema(adSchemaTables)
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
Set Tables = mRes
End Function
Public Function UserTables() As ADODB.Recordset
Dim mRes As ADODB.Recordset
If m_AutoConnect Then
Call OpenConn
End If
Set mRes = m_Conn.OpenSchema(adSchemaTables)
mRes.Filter = "table_type = 'TABLE'"
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
Set UserTables = mRes
End Function
Public Function Fields(ByVal TableName As String) As ADODB.Recordset
Dim mRes As ADODB.Recordset
If m_AutoConnect Then
Call OpenConn
End If
Set mRes = m_Conn.OpenSchema(adSchemaColumns)
mRes.Filter = "table_name = '" & TableName & "'"
mRes.Sort = "ORDINAL_POSITION ASC"
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
Set Fields = mRes
End Function
Public Function KeyField(ByVal TableName As String) As String
Dim mRes As ADODB.Recordset
Dim mKeyFieldName As String
If m_AutoConnect Then
Call OpenConn
End If
Set mRes = m_Conn.OpenSchema(adSchemaPrimaryKeys)
mRes.Filter = "table_name = '" & TableName & "'"
mRes.ActiveConnection = Nothing
If m_AutoConnect Then
Call CloseConn
End If
If mRes.RecordCount > 0 Then
mRes.MoveFirst
Do While Not mRes.EOF
If mRes.Fields("column_name").Value <> "" Then
mKeyFieldName = mRes.Fields("column_name").Value
Exit Do
End If
Loop
End If
KeyField = mKeyFieldName
End Function
Public Sub ReleaseRecordset(res As ADODB.Recordset)
Set res = Nothing
End Sub