Async call error handling

[bbosley]

I have VB 6.0 SP3 code that is executing a series of SQL Server 7.0 stored procedure with ADO 2.1 connection and command objects. My problem is when the stored procedure raises an error back to the calling VB app. The VB app does not handle the error. Here is an example of the code:


In General Declaration

Dim conRating As ADODB.Connection
Dim cmTemp As ADODB.Command


Public Sub BeginRating()

On Error GoTo errhandler

Set conRating = New ADODB.Connection
Set cmTemp = New ADODB.Command

With conRating
.ConnectionString = g_strCONNECTION_STRING
.Open , , , adAsyncConnect

Do While .State = adStateConnecting
DoEvents
Loop

End With

With cmTemp
.ActiveConnection = conRating
.CommandType = adCmdStoredProc
.Parameters.Append .CreateParameter("QuoteID", adInteger,
adParamInput, 4)
.Parameters.Append .CreateParameter("PlanID", adInteger,
adParamInput, 4)

.Parameters.Item(0).Value = frmRate.txtQuote
.Parameters.Item(1).Value = frmRate.txtPlan

.CommandTimeout = 0 'Override default of 60 seconds

.CommandText = "dbo.spr_ClearWorkTables"
.Execute , , adAsyncExecute

Do While .State = adStateExecuting
DoEvents
Loop

' Clear Previous Entries
.CommandText = "dbo.spr_ClearPreviousEntries"
.Execute , , adAsyncExecute

Do While .State = adStateExecuting
DoEvents
Loop

' Append additional parameters needed for all the other rating calls
.Parameters.Append .CreateParameter("RequestUserID", adVarChar, adParamInput, 10)
.Parameters.Append .CreateParameter ("RequestDateTime", adDate, adParamInput, 8)

.Parameters.Item(2).Value = fMDIMain.pstrLogin
.Parameters.Item(3).Value = Now()

'Rating1
.CommandText = "dbo.spr_Rating1"
.Execute , , adAsyncExecute

Do While .State = adStateExecuting
DoEvents
Loop

GoTo CleanUp

errhandler:

' There is more of an error handler in here but the fact is the error handler is not tripped.

msgbox err.number & err.description

CleanUp:

Set cmTemp = Nothing
Set conRating = Nothing

End Sub


I have tried WithEvents on the Connection object but always get an error message. Here is the additional code:

Dim WithEvents conRating As ADODB.Connection

and

Private Sub conRating_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As
ADODB.Connection)

If adStatus = adStatusErrorsOccurred Then
With pError
Err.Raise .Number, .Source, .Description
End With
End If

End Sub

The SQL Stored proc raises the error like:

SET @chvErrorMessage = 'Can not determine LTD Provincial Adjustment Factor'
RAISERROR (@chvErrorMessage,16,1)
RETURN


The error I get when I use the WithEvents is:

Runtime error '-2147217915 (80040e05)': Object was open

This error was raised from within the "Private Sub
conRating_ExecuteComplete".

Any Help would be greatly appreciated. I am looking for examples on handling errors from an Async call with ADO. I found a few things in MSDN but nothing with an example.

Thanks

Bryan Bosley