VB Async Call to Stored Proc error handling
Bryan Bosley
I have 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
Ric VA
analyzer to narrow down where the failure occurs?
I would use the events to trigger off the next "state" of your code, instead
of having the do while loops. Then, depending on the status code, you can
determine to call the next state or exit. As the events occur, do a debug
print on the current state, the event and whatever else you want. This code
should be in its own class, with clean up happening on the class terminate.
I sort of split it up below.
Sincerely,
Ric Vander Ark
"Bryan Bosley" <bbosley...@pisc.com> wrote in message
news:01c0bbb9$dfe5d820$6c155a0a@lr404w61...
>
> I have 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
>
dim MyState
>
> 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
> End With
MyState=1
end sub
>
> 'xxx Do While .State = adStateConnecting
> 'xxx DoEvents
> 'xxx Loop
>
at this point you would be the ConnectComplete event should fire. Check the
status and go to State 2
If an error happens then bomb out (gracefully)
private sub BuildRatingState2()
>
> 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
>
MyState=2
end sub
> 'xxx Do While .State = adStateExecuting
> 'xxx DoEvents
> 'xxx Loop
>
When the ExecuteComplete has fired then goto state 3
private sub BuildRatingState3()
> ' Clear Previous Entries
> .CommandText = "dbo.spr_ClearPreviousEntries"
> .Execute , , adAsyncExecute
>
MyState=3
end sub
> 'xxx Do While .State = adStateExecuting
> 'xxx DoEvents
> 'xxx Loop
>
When the ExecuteComplete has fired then goto state 4
private sub BuildRatingState4()
> ' 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
MyState=4
end sub
> 'xxx Do While .State = adStateExecuting
> 'xxx DoEvents
> 'xxx Loop
>
When the ExecuteComplete has fired then goto state 5
private sub BuildRatingState5()
Meade Robboy
I seem to recall that the error will get raised in the ExecuteComplete
event - you need to declare the connection and / or command as WithEvents to
get the event to appear. It's been a while since I played with this stuff,
but I think it's a good place to start looking...
-Meade
"Bryan Bosley" <bbosley...@pisc.com> wrote in message
news:01c0bbb9$dfe5d820$6c155a0a@lr404w61...
>
Bryan Bosley
I am reading your note right. My problem now is that I am always receiving
the error message "Object is Open" twice. It gets handled in the
errHandler in conRating_ExecuteComplete but when I hit the END SUB of
conRating_ExecuteComplete it triggers the error routine again. Here is the
code:
Private Sub Timer1_Timer()
If g_blnBeginRating = False Then
g_blnBeginRating = True
Call Rating
End If
End Sub
Public Sub Rating()
Dim pmTemp As ADODB.Parameter
' define variables required for error handling
Dim TtypErrorData As TtypUIErrorInfo
Dim RtypErrorData As RtypUIErrorInfo
Dim blnTest As Boolean
Dim strLogFileName As String
'On Error GoTo errhandler
'Create each individual Rating process
strLogFileName = "c:\" & fMDIMain.pstrLogin & "RatingLog.txt"
Open strLogFileName For Output As #1
Print #1, "Beginning Rating for Quote: " & fMDIMain.pcurQuoteID & _
" Plan: " & fMDIMain.pintPlanID_NewValue & _
" Description: " & fMDIMain.pstrPlanDescription
Print #1, " "
Print #1, "Start Time: " & Now()
Print #1, " "
Set conRating = New ADODB.Connection
Set cmTemp = New ADODB.Command
With conRating
.ConnectionString = g_strCONNECTION_STRING
.Open , , , adAsyncConnect
End With
cmdCancel.Enabled = True
MyState = 1
End Sub
Private Sub Rating2()
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
'This code to clear the work tables is here at the top just for
'the user's testing. In production it will be the last step to
'clear out the work tables after rating is run. We also need to
change
'the progress bar for WriteResults to 10 when we uncomment
ClearWorkTables.
'We moved it to the top for user testing incase there are problems
'in the user testing then we still have the intermediate results to
verify with.
'When this is moved to production this call at the top can be
deleted
'and the call at the bottom can be uncommented.
'This code will clear out the perminant work tables before the
rating
'runs.
'Clear Work Tables
Print #1, "Clear work tables start Time: " & Now()
.CommandText = "dbo.spr_ClearWorkTables"
frmRate.lblProgress.Caption = "Clearing Work Tables"
.Execute , , adAsyncExecute
frmRate.pbRating.Value = 1
Print #1, "Clear work tables end Time: " & Now()
Print #1, " "
End With
MyState = 2
End Sub
Private Sub Rating3()
With cmTemp
Print #1, " "
Print #1, "Clear previous entries Start Time: " & Now()
' Clear Previous Entries
.CommandText = "dbo.spr_ClearPreviousEntries"
frmRate.lblProgress.Caption = "Clearing Previous Entries"
.Execute , , adAsyncExecute
frmRate.pbRating.Value = 1
Print #1, "Clear pervious entries end Time: " & Now()
End With
MyState = 3
End Sub
Private Sub Rating4()
With cmTemp
Print #1, " "
' 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()
Print #1, " Basic Life Rating Start Time: " & Now()
' Basic Life Rating
.CommandText = "dbo.spr_BasicLifeRating"
frmRate.lblProgress.Caption = "Rating Basic Life (Product 1 of 7)"
.Execute , , adAsyncExecute
frmRate.pbRating.Value = 2
Print #1, " Basic Life Rating End Time: " & Now()
End With
MyState = 4
End Sub
Private Sub Rating5()
With cmTemp
Print #1, " "
Print #1, " LTD Rating Start Time: " & Now()
'LTD Rating
.CommandText = "dbo.spr_LTDRating"
frmRate.lblProgress.Caption = "Rating LTD/CTP (Product 5 of 7)"
.Execute , , adAsyncExecute
frmRate.pbRating.Value = 6
Print #1, " LTD Rating End Time: " & Now()
End With
MyState = 5
End Sub
Private Sub conRating_ConnectComplete(ByVal pError As ADODB.Error, adStatus
As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
If adStatus = adStatusOK Then
frmRate.lblProgress.Caption = "Connection to SQL Server Complete"
Call Rating2
Else
frmRate.lblProgress.Caption = "Connection to SQL Server failed"
End If
End Sub
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)
' define variables required for error handling
Dim TtypErrorData As TtypUIErrorInfo
Dim RtypErrorData As RtypUIErrorInfo
Dim blnTest As Boolean
On Error GoTo errhandler
If adStatus = adStatusOK Then
frmRate.lblProgress.Caption = "Execute Complete"
Select Case MyState
Case 1
Call Rating2
Case 2
Call Rating3
Case 3
Call Rating4
Case 4
Call Rating5
Case 5
frmRate.lblProgress.Caption = "Execute Complete"
End Select
ElseIf adStatus = adStatusErrorsOccurred Then
frmRate.lblProgress.Caption = "Execute failed"
With pError
Err.Raise .Number, .Source, .Description
End With
End If
GoTo Cleanup
errhandler:
MsgBox "Error Occured in Begin Rating: " & Err.Description
' log the error and display message to user
With TtypErrorData
.dteErrorDate = Now()
.lngErrorNumber = Err.Number
.strErrorDescription = Err.Description
.strMethod = "BeginRating"
.strMsgboxTitle = "Error occurred."
.strObject = Me.Name
.strUserName = fMDIMain.pstrLogin
End With
Print #1, "Crash Time: " & Now()
Print #1, " "
Print #1, "Rating ERROR for Quote: " & fMDIMain.pcurQuoteID & _
" Plan: " & fMDIMain.pintPlanID_NewValue & _
" Description: " & fMDIMain.pstrPlanDescription
Print #1, " "
Print #1, "--------------------"
Print #1, "ERROR IN BEGIN RATING: " & TtypErrorData.lngErrorNumber & "
" & TtypErrorData.strErrorDescription
LSet RtypErrorData = TtypErrorData
blnTest = fblnUIError(True, RtypErrorData.strData)
' If cmTemp.State = adStateExecuting Then
' cmTemp.Cancel
' End If
' If CBool(conRating.State And adStateOpen) Then
' conRating.Cancel
' MsgBox "Rating succesfully cancelled!!", vbOKOnly, "Rating
Cancelled!"
' End If
Cleanup:
' Close the log file
Close #1
adStatus = adStatusCancel
Set cmTemp = Nothing
Set conRating = Nothing
' Unload Me
End Sub
Ric VA <lo...@fidalgo.net> wrote in article
<98627804...@localhost.fidalgo.net>...