OUTPUT Params and RecordSet Problem

I'm trying to call a procedure that has OUTPUT params and returns a record
set. In Excel 2003 VBA (Microsoft ActiveX Data Objects 2.8 Library), I seem
to only be able to get one or the other.

In SQL Server 2005, I got the expected results running this script:

USE ICEBOX;
SET ANSI_NULLS ON;
SET QUOTED_IDENTIFIER ON;
GO

IF EXISTS
(SELECT * FROM INFORMATION_SCHEMA.ROUTINES
WHERE
ROUTINE_TYPE = 'PROCEDURE'
AND ROUTINE_SCHEMA = 'dbo'
AND ROUTINE_NAME = 'USP_ProcedureTest'
)
DROP PROCEDURE dbo.USP_ProcedureTest;
GO

CREATE PROCEDURE dbo.USP_ProcedureTest
(
@String256 VARCHAR(256)
,@ReverseString256 VARCHAR(256) OUTPUT
,@RStringLength INT OUTPUT
) AS SET NOCOUNT ON;
BEGIN
SET @ReverseString256 = REVERSE(@String256);
SET @RStringLength = LEN(@ReverseString256);

SELECT '@String256' AS Variable, @String256 AS Value
UNION ALL
SELECT '@ReverseString256' AS Variable, @ReverseString256 AS Value
UNION ALL
SELECT 'RETURNS' AS Variable, CAST(@RStringLength AS VARCHAR) AS Value;
END;
GO

DECLARE @Return INT, @Input VARCHAR(256), @OutPut VARCHAR(256), @Len INT;
SET @Input = 'StringToReverse';
EXEC @Return = dbo.USP_ProcedureTest
@String256 = @Input
,@ReverseString256 = @Output OUTPUT
,@RStringLength = @Len OUTPUT;
PRINT '@Return' + CHAR(9) + CAST(@Return AS VARCHAR);
PRINT '@Input' + CHAR(9) + @Input;
PRINT '@Output' + CHAR(9) + @Output;
PRINT '@Len' + CHAR(9) + CAST(@Len AS VARCHAR);
GO

In Excel 2003 VBA, in the following function, I have this section:


With ADODB_Command
.ActiveConnection = ADODB_Connection
.CommandType = adCmdStoredProc
.CommandText = "dbo.USP_ProcedureTest"
.Parameters.Refresh
.Parameters("@String256").Value = "StringToReverse"
.Execute Options:=adExecuteNoRecords
strReverse = .Parameters("@ReverseString256").Value
lngLength = .Parameters("@RStringLength").Value
Set ADODB_RecordSet = .Execute()
End With

Notice I have .Execute in there twice. I did that because it seems I have to
use

..Execute Options:=adExecuteNoRecords

to get the OUTPUT parameters to not be NULL, and I use

Set ADODB_RecordSet = .Execute()

To get the record set back. It seems to me I should be able to do both tasks
without executing the statement twice.

Any Ideas?

Thanks, Bob

Here is the full Function

Option Explicit
'Include Reference to Microsoft ActiveX Data Objects 2.8 Library

Private Function ExecuteTestProcedure(strConnection As String, Optional
blnIncludeFieldNames As Boolean = True, Optional strError As String = "") As
Variant
Dim ADODB_Connection As New ADODB.Connection
Dim ADODB_Command As New ADODB.Command
Dim ADODB_RecordSet As ADODB.Recordset

Dim strReverse As String, lngLength As Long, varReturnSet As Variant
Dim varRecordSet As Variant, strFieldNames() As String
Dim lngRowCount As Long, lngFieldCount As Long
Dim r&, c&

varReturnSet = Empty
On Error GoTo ExitRoutine

'If strConnection is an existing file, assume UDL file, otherwise,
regular string.
If Len(Dir(strConnection, vbNormal)) > 0 Then
ADODB_Connection.ConnectionString = "FILE NAME=" + strConnection
Else
ADODB_Connection.ConnectionString = strConnection
End If

ADODB_Connection.Open

If ADODB_Connection.State <> adStateOpen Then
strError = "Could not open database"
GoTo ExitRoutine
End If

With ADODB_Command
.ActiveConnection = ADODB_Connection
.CommandType = adCmdStoredProc
.CommandText = "dbo.USP_ProcedureTest"
.Parameters.Refresh
.Parameters("@String256").Value = "StringToReverse"
.Execute Options:=adExecuteNoRecords
strReverse = .Parameters("@ReverseString256").Value
lngLength = .Parameters("@RStringLength").Value
Set ADODB_RecordSet = .Execute()
End With

If ADODB_RecordSet Is Nothing Then
strError = "ADODB_RecordSet Is Nothing"
varReturnSet = Empty
GoTo ExitRoutine
End If

With ADODB_RecordSet
lngFieldCount = .Fields.Count
ReDim strFieldNames(1 To lngFieldCount)
For c = 1 To lngFieldCount
strFieldNames(c) = .Fields(c - 1).Name
Next c

If .BOF Or .EOF Then
varRecordSet = Empty
lngRowCount = 0
Else
varRecordSet = .GetRows
lngRowCount = UBound(varRecordSet, 2) - LBound(varRecordSet, 2)
+ 1
End If
End With

If blnIncludeFieldNames And lngRowCount <= 0 Then
ReDim varReturnSet(0 To 0, 1 To lngFieldCount) As Variant
End If

If blnIncludeFieldNames And lngRowCount > 0 Then
ReDim varReturnSet(0 To lngRowCount, 1 To lngFieldCount) As Variant
End If

If Not blnIncludeFieldNames And lngRowCount > 0 Then
ReDim varReturnSet(1 To lngRowCount, 1 To lngFieldCount) As Variant
End If

If LBound(varReturnSet, 1) = 0 Then
For c = 1 To lngFieldCount
varReturnSet(0, c) = strFieldNames(c)
Next c
End If

If lngRowCount > 0 Then
For r = 1 To lngRowCount
For c = 1 To lngFieldCount
varReturnSet(r, c) = varRecordSet(c - 1, r - 1)
Next c
Next r
End If

ExitRoutine:
If Err.Number <> 0 Then
strError = Err.Description + vbCrLf + Err.Source
End If
On Error GoTo 0
ExecuteTestProcedure = varReturnSet
If Not ADODB_RecordSet Is Nothing Then
If ADODB_RecordSet.State = adStateOpen Then
ADODB_RecordSet.Close
End If
Set ADODB_RecordSet = Nothing
End If
Set ADODB_Command = Nothing
If Not ADODB_Connection Is Nothing Then
If ADODB_Connection.State = adStateOpen Then
ADODB_Connection.Close
End If
Set ADODB_Connection = Nothing
End If
End Function


.