Ошибка "Объект был открыт" для больших наборов результатов? - PullRequest
Новая
       60

Ошибка "Объект был открыт" для больших наборов результатов?

1 голос
/ 19 февраля 2020

Я получаю сообщение об ошибке «Объект был открыт» при выполнении хранимой процедуры с большими объемами данных. Эта процедура запускается из приложения VB 6.00 в SQL 2005. При запуске сценария в SQL нет проблем 

rs.Open cmd, Options:=adCmdStoredProc

ВАЖНО: эта ошибка возникает ТОЛЬКО с большим объемом данных. Пороговый уровень составляет около 250000 строк данных. Если получено больше этого количества данных, возникает ошибка. Если меньше, то нет проблем.

Любое предложение было бы замечательно

Спасибо

Ответы [ 2 ]

0 голосов
/ 28 февраля 2020

попробуйте использовать этот модуль, он может помочь вам избежать использования набора записей для процедуры SQL.

Уведомление Пожалуйста, используйте собственную строку подключения, чтобы заменить мою строку подключения. Мой код был разработан для доступа к базе данных, файл которой заканчивается на ".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
0 голосов
/ 20 февраля 2020

Попробуйте использовать другие типы курсоров. На объекте соединения попробуйте переключиться с adUseClient на adUseServer или наоборот. 

rs.Open cmd, , adOpenStatic, adLockReadOnly, Options:=adCmdStoredProc
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...