ADO Recordset Not Staying Open in VBA - “Operation

Question

I don't really understand what has happened here. I'm using Excel VBA to connect to a SQL Server Express database and return an ADO Recordset. I had it working initially, but my code was a bit messy so I created a new module and copied the code across, tidying it up as I went along.

Now, when I try to run the Sub just to return a the recordcount, I get the error "The operation is not allowed when the object is closed." The code breaks on the MsgBox line.

Here is the simplified code:

Dim Server As String
Server = "ServerName"

Dim Database As String
Database = "DatabaseName"

Dim UserID As String
UserID = "UserID"

Dim Pwd As String
Pwd = "Password"

Dim StoredProcedure As String
StoredProcedure = "StoredProcedureName"

Dim conn As New ADODB.Connection
conn.ConnectionString = "Driver={SQL Server};Server=" & Server & "; Database=" & Database & "; UID = " & UserID & "; PWD=" & Pwd & ""
conn.Open

Dim Cmd As New ADODB.Command
Cmd.ActiveConnection = conn
Cmd.CommandText = StoredProcedure
Cmd.CommandType = adCmdStoredProc

Dim params() As String
ReDim Preserve params(4, 2)

params(0, 0) = "Param1"
params(1, 0) = CStr(adInteger)
params(2, 0) = CStr(adParamInput)
params(4, 0) = CStr(6)

params(0, 1) = "Param2"
params(1, 1) = CStr(adInteger)
params(2, 1) = CStr(adParamInput)
params(4, 1) = CStr(6)

params(0, 2) = "Param3"
params(1, 2) = CStr(adInteger)
params(2, 2) = CStr(adParamInput)
params(4, 2) = CStr(15)

Dim sParam4 as String
If Not sParam4 = "" Then
    ReDim Preserve params(4, UBound(params, 2) + 1)
    params(0, UBound(params, 2)) = "Param4"
    params(1, UBound(params, 2)) = CStr(adChar)
    params(2, UBound(params, 2)) = CStr(adParamInput)
    params(3, UBound(params, 2)) = "1"
    params(4, UBound(params, 2)) = sParam4
End If

Dim sParam5 as String
If Not sParam5 = "" Then
    ReDim Preserve params(4, UBound(params, 2) + 1)
    params(0, UBound(params, 2)) = "Param5"
    params(1, UBound(params, 2)) = CStr(adChar)
    params(2, UBound(params, 2)) = CStr(adParamInput)
    params(3, UBound(params, 2)) = Len(sParam5)
    params(4, UBound(params, 2)) = sParam5
End If

Dim Prm As ADODB.Parameter
Set Prm = New ADODB.Parameter
Dim i As Integer
For i = 0 To UBound(params, 2)
    If params(1, i) = CStr(adChar) Then
        Set Prm = Cmd.CreateParameter(params(0, i), CInt(params(1, i)), CInt(params(2, i)), CInt(params(3, i)))
        Cmd.Parameters.Append Prm
        Cmd.Parameters(params(0, i)).Value = params(4, i)
    Else
        Set Prm = Cmd.CreateParameter(params(0, i), CInt(params(1, i)), CInt(params(2, i)))
        Cmd.Parameters.Append Prm
        Cmd.Parameters(params(0, i)).Value = CInt(params(4, i))
    End If
Next i

Dim rs As New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open Cmd, , adOpenStatic, adLockOptimistic

MsgBox ("Success! " & rs.RecordCount & " Records Returned!")

When I look at the rs variable in the Locals window, all of the properties are listed as showing the same error message. To me, it seems as if the recordset is opening correctly, but then immediately closing itself.

What's weird is that the original (messy) sub now also doesn't work, throwing the same error. I don't think that I changed anything there, just copied it to the new sub.

I've commented out the entire module that the old sub was in, just in case there was any sort of conflicting variable situation going on. This didn't make any difference.

I just can't see what's wrong with it! I've done lots of research and reading, and to my untrained-but-enthusiastic eye, it all seems fine.

Any help would be much appreciated.

EDIT: Here is the Stored Procedure:

USE [MyDatabase]
GO
/****** Object:  StoredProcedure [dbo].[MyProcedure]    Script Date: 14/09/2015 11:39:00 ******/
SET ANSI_NULLS ON
GO
SET QUOTED_IDENTIFIER ON
GO
-- =============================================
-- Author:      <Author,,Name>
-- Create date: <Create Date,,>
-- Description: <Description,,>
-- =============================================
ALTER PROCEDURE [dbo].[MyProcedure] 
    -- Add the parameters for the stored procedure here
    @Param1 int, @Param2 int, @Param3 int, @Param4 char(1), @Param5 varchar(20) = NULL, @Param6 varchar(20) = NULL, @Param7 varchar(20) = NULL
AS
BEGIN
    -- SET NOCOUNT ON added to prevent extra result sets from
    -- interfering with SELECT statements.
    SET NOCOUNT ON;
    SET ANSI_WARNINGS OFF;

    -- Insert statements for procedure here
    DECLARE @cols AS NVARCHAR(MAX), @query  AS NVARCHAR(MAX)

SET @cols = '';
SELECT @cols = @cols + ',' + QUOTENAME([Field3]) FROM View1
WHERE Field2 = @Param2 AND Field1 = @Param1

SET @cols = STUFF(@cols,1,1,'');


IF @Param5 IS NOT NULL
   SET @query = 'SELECT Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Field10, Field11, Field12, Field13, Field14,' + @cols + ' FROM
(
    SELECT
        Table1.Field1, 
        Table1.Field2, 
        Table1.Field3, 
        Table1.Field4, 
        Table1.Field5, 
        Table1.Field6, 
        Table1.Field7, 
        Table1.Field8, 
        Table1.Field9, 
        Table1.Field10, 
        Table1.Field11, 
        Table1.Field12, 
        Table1.Field13, 
        Table1.Field14, 
        Table2.Field2, 
        Table3.Field1
    FROM Table3 
        LEFT OUTER JOIN Table2 ON Table3.Field1 = Table2.Field1 
            AND Table3.Field2 = Table2.Field2
        LEFT OUTER JOIN Table4 ON Table3.Field4 = Table4.Field1 
            AND Table3.Field2 = Table4.Field3 
        RIGHT OUTER JOIN Table1 ON Table2.Field1 = Table1.Field1
            AND Table2.Field2 = Table1.Field15
    WHERE Table1.Field2 = ' + CAST(@Param3 AS char(1)) + '
        AND Table1.Field12 = ''' + @Param5 + '''
        AND Table1.Field15 = ' + CAST(@Param1 AS char(2)) + '
) 
AS UP
PIVOT(MAX(Field2) FOR UP.ID IN (' + @cols + ')) AS PVT '
ELSE IF @Param6 IS NOT NULL
   SET @query = 'SELECT Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Field10, Field11, Field12, Field13, Field14,' + @cols + ' FROM
(
    SELECT 
        Table1.Field1, 
        Table1.Field2, 
        Table1.Field3, 
        Table1.Field4, 
        Table1.Field5, 
        Table1.Field6, 
        Table1.Field7, 
        Table1.Field8, 
        Table1.Field9, 
        Table1.Field10, 
        Table1.Field11, 
        Table1.Field12, 
        Table1.Field13, 
        Table1.Field14, 
        Table2.Field2, 
        Table3.Field1
    FROM Table3 
        LEFT OUTER JOIN Table2 ON Table3.Field1 = Table2.Field1
            AND  Table3.Field2 = Table2.Field2
        LEFT OUTER JOIN Table4 ON Table3.Field4 = Table4.Field1 
            AND Table3.Field2 = Table4.Field3 
        RIGHT OUTER JOIN Table1 ON Table2.Field1 = Table1.Field1
            AND Table2.Field2 = Table1.Field15
    WHERE Table1.Field2 = ' + CAST(@Param3 AS char(1)) + '
        AND Table1.Field13 = ''' + @Param6 + '''
        AND Table1.Field15 = ' + CAST(@Param1 AS char(2)) + '
) 
AS UP
PIVOT(MAX(Field2) FOR UP.ID IN (' + @cols + ')) AS PVT '

ELSE IF @Param7 IS NOT NULL

    SET @query = 'SELECT Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Field10, Field11, Field12, Field13, Field14,' + @cols + ' FROM
(
    SELECT 
        Table1.Field1, 
        Table1.Field2, 
        Table1.Field3, 
        Table1.Field4, 
        Table1.Field5, 
        Table1.Field6, 
        Table1.Field7, 
        Table1.Field8, 
        Table1.Field9, 
        Table1.Field10, 
        Table1.Field11, 
        Table1.Field12, 
        Table1.Field13, 
        Table1.Field14, 
        Table2.Field2, 
        Table3.Field1
    FROM Table3 
        LEFT OUTER JOIN Table2 ON Table3.Field1 = Table2.Field1
            AND Table3.Field2 = Table2.Field2
        LEFT OUTER JOIN Table4 ON Table3.Field4 = Table4.Field1 
            AND Table3.Field2 = Table4.Field3 
        RIGHT OUTER JOIN Table1 ON Table2.Field1 = Table1.Field1
            AND Table2.Field2 = Table1.Field15
    WHERE Table1.Field2 = ' + CAST(@Param3 AS char(1)) + '
        AND Table1.Field14 = ''' + @Param7 + '''
        AND Table1.Field15 = ' + CAST(@Param1 AS char(2)) + '
) AS UP

PIVOT(MAX(Field2) FOR UP.ID IN (' + @cols + ')) AS PVT '

ELSE

    SET @query = 'SELECT Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Field10, Field11, Field12, Field13, Field14,' + @cols + ' FROM
(
SELECT 
    Table1.Field1, 
    Table1.Field2, 
    Table1.Field3, 
    Table1.Field4, 
    Table1.Field5, 
    Table1.Field6, 
    Table1.Field7, 
    Table1.Field8, 
    Table1.Field9, 
    Table1.Field10, 
    Table1.Field11, 
    Table1.Field12, 
    Table1.Field13, 
    Table1.Field14, 
    Table2.Field2, 
    Table3.Field1
FROM Table3 
    LEFT OUTER JOIN Table2 ON Table3.Field1 = Table2.Field1
        AND Table3.Field2 = Table2.Field2
    LEFT OUTER JOIN Table4 ON Table3.Field4 = Table4.Field1 
        AND Table3.Field2 = Table4.Field3 
    RIGHT OUTER JOIN Table1 ON Table2.Field1 = Table1.Field1
        AND Table2.Field2 = Table1.Field15
WHERE Table1.Field2 = ' + CAST(@Param3 AS char(1)) + '
    AND Table1.Field3 = ''' + @Param4 + '''
    AND Table1.Field15 = ' + CAST(@Param1 AS char(2)) + '
) AS UP

PIVOT(MAX(Field2) FOR UP.ID IN (' + @cols + ')) AS PVT '

EXECUTE (@query)

Set NOCOUNT OFF;
END

I know that the logic behind the parameters isn't very... logical.. but it works the way I need it to for now. It is something I'll change as I'm working on it.

I should also say that I omitted the section of my VBA code that handles the parameters for the SP when I first posted the question. I'm just leaving work now, but I'll add it in once I get home. I don't think the problem lies there though. I basically work through a string array of the parameters and append them to the Cmd object.

EDIT: I've now added the code for creating the parameters and passing them to the Cmd object. Again, it's a bit convoluted, but it's what came out of my head at the time and it does work. I'll revisit the logic once the recordset is populated.

Answer 1

This is a bit long for a comment so I'll put it here as a possible answer. Please try:

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
With rs
    Set .ActiveConnection = conn
    .LockType = adLockOptimistic
    .CursorLocation = adUseServer
    .CursorType = adOpenForwardOnly
    .Open "SET NOCOUNT ON"
End With
rs.Open Cmd, , , , adCmdStoredProc

MsgBox ("Success! " & rs.RecordCount & " Records Returned!")

Answer 2

I had a similar issue and found two things that killed the query results over ODBC

• Count of intermediate values for processing before the final output. Fixed with "set nocount on" at the start of the query

• null values being aggregated away - running the query directly on SQL Server showed the message "Warning: Null value is eliminated by an aggregate or other SET operation." Fixed by chasing down each of them and either replacing with empty strings, zeros or whatever low value makes sense and doesn't impact the query results.

I think in both cases the warning message was output before the records, so the storage recordset was 'filled' with that warning, but no data. On SQL Server, these warnings silently sit in the message log but don't impact the query results, so the temptation is to let them be and move on to higher priority work.

Answer 3

Please try the following code:

Public Sub AdoTestConnection()
Dim conServer As ADODB.Connection
Dim rstResult As ADODB.Recordset
Dim strDatabase As String
Dim strServer As String
Dim strSQL As String

strServer = "YourServerName"
strDatabase = "YourDatabaseName"

Set conServer = New ADODB.Connection
conServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
    & "DATA SOURCE=" & strServer & "; " _
    & "INITIAL CATALOG=" & strDatabase & "; " _
    & "User ID=" & strLogin & ";" _
    & "Password=" & strPassword
On Error GoTo SQL_ConnectionError
conServer.Open
On Error GoTo 0

Set rstResult = New ADODB.Recordset
strSQL = "set nocount on; "
strSQL = strSQL & "select  1 "
rstResult.ActiveConnection = conServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0

If Not rstResult.EOF And Not rstResult.BOF Then
    MsgBox "Connection worked. Server returned " & rstResult.Fields(0).Value
Else
    MsgBox "Connection worked. The server did not return any value."
End If

Exit Sub

SQL_ConnectionError:
MsgBox "Problems connecting to the server." & Chr(10) & "Aborting..."
Exit Sub

SQL_StatementError:
MsgBox "Connection established. Yet, there is a problem with the SQL syntax." & Chr(10) & "Aborting..."
Exit Sub

End Sub

If the above code works then you can change the SQL command with your procedure like so:

strSQL = "set nocount on; "
strSQL = strSQL & "exec StoredProcedureName @Parm1 = " & intValue1 & ", "
strSQL = strSQL & "                         @Parm2 = " & intValue2 & ", "
strSQL = strSQL & "                         @Parm3 = " & intValue3 & ", "
strSQL = strSQL & "                         @Parm4 = N'" & strValue1 & "', "
strSQL = strSQL & "                         @Parm5 = N'" & strValue2 & "', "
strSQL = strSQL & "                         @Parm6 = N'" & strValue3 & "', "
strSQL = strSQL & "                         @Parm7 = N'" & strValue4 & "' "

I strongly favor this approach over your current because it is much easier to debug. If you ever run into a problem with your SQL syntax you can simply request the content of strSQL like so:

Debug.Print strSQL

Then you can copy the result of that into SQL Server Management Studio (SSMS) and verify the result there. You may even come to the conclusion that you do not want to use a stored procedure and copy the entire content of the SP into your VBA code.