Error Handling in Vb6.0

I'm not sure what you want but here's something I found on the web.

Private Sub CallMyStoredProc()

On Error GoTo ErrorHandler

Err.Clear

'Begin Transaction
gconAdo.BeginTrans

Set cdContractActivate = New ADODB.Command

'Call contractReactivateProc.
With cdContractActivate
    .ActiveConnection = gconAdo
    .CommandType = adCmdStoredProc
    .CommandText = "Contract_React" 'Stored Procedure Name
End With

Err.Clear

Set paramContractNo = cdContractActivate.CreateParameter("paramContractNo", adVarChar, adParamInput, 6)
Set paramReason = cdContractActivate.CreateParameter("paramReason", adVarChar, adParamInput, 250)
Set paramErrCode = cdContractActivate.CreateParameter("paramErrCode", adNumeric, adParamOutput)
Set paramErrLoc = cdContractActivate.CreateParameter("paramErrLoc", adVarChar, adParamOutput, 100)
Set paramErrMsg = cdContractActivate.CreateParameter("paramErrMsg", adVarChar, adParamOutput, 100)

Err.Clear

cdContractActivate.Parameters.Append paramContractNo
cdContractActivate.Parameters.Append paramReason
cdContractActivate.Parameters.Append paramErrCode
cdContractActivate.Parameters.Append paramErrLoc
cdContractActivate.Parameters.Append paramErrMsg

Err.Clear

paramContractNo.Value = txtContractNo.text
paramReason.Value = txtComments.text

Err.Clear

cdContractActivate.Execute

'The Stored Procedure will return 0 for success and 1 for exception.
If paramErrCode.Value <> 0 Then
    gconAdo.RollbackTrans
    lblMessage.Caption = "Contract Cannot be Restored to former state .."
'Next line is optional and you can choose to return another code to the calling program.
Err.Raise -20001, "CallStoredProc", paramErrCode.Value
Else
    gconAdo.CommitTrans
    lblMessage.Caption = "Contract Re-Activated ..!!"
    lnReturnvalue = 0
End If

'USEFUL FOR DEBUGGING..
'MsgBox "Stored Procedure executed with return code = " & paramErrCode.Value & "" & _
        vbCrLf & "**** Message from Stored Procedure is ****" & _
        vbCrLf & "Error Location = " & paramErrLoc.Value & _
        vbCrLf & "Error Message = " & paramErrMsg.Value, vbInformation + vbOkOnly
MsgBox paramErrMsg.Value, vbInformation, "Contract ReActivation"

Err.Clear

If Not cdContractActivate Is Nothing Then
    Set cdContractActivate = Nothing
End If

Exit Sub

ErrorHandler:
    If Err.Number = 0 Then
        MsgBox "Stored Procedure returned with return code 1 " & _
           vbCrLf & "**** Message from Stored Procedure is ****" & _
           vbCrLf & "Error Location = " & paramErrLoc.Value & _
           vbCrLf & "Error Message = " & paramErrMsg.Value, vbInformation + vbOkOnly
    Else
         MsgBox "Error Occured =  " & Err.Number & " and " & _
                vbCrLf & "Description is " & Err.Description, vbOkOnly + vbCritical
    End If
    If Not cdContractActivate Is Nothing Then
        Set cdContractActivate = Nothing
    End If
End Sub 

Select allOpen in new window

Hi Martin,

Thanks for response..How do i call this in  VB form..
following is the code


Code from Module :

Public Function SQL_Execute(ByVal sXml As String) As Boolean

On Error GoTo ErrorHandler

    Dim oData           As DataControl.CDataControl

    Set oData = New CDataControl

    SQL_Execute = oData.ExecuteSQL(sConnectString, sXml)

ExitFunction:
    Set oData = Nothing
    Exit Function

ErrorHandler:

    MsgBox "SQL_Execute::" & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & vbCrLf & "sConnectString: " & sConnectString & vbCrLf & vbCrLf & "sXML: " & sXml
   
    Resume ExitFunction
   

End Function

-------------------------

I want to throw message box in the following code in vb form


Private Sub cmdUpdateBucketExcep_Click()

Dim strInsertSQL As String
Dim strUpdateSQL As String
Dim StrXml As String
Dim str As String
On Error GoTo ErrorHandler

'If dgBucketExcepOriginal.Visible = False Then
'If getCurrRS Is Nothing Then
With rsbcktexcep
   .MoveFirst
    Do While Not .EOF
       
            strInsertSQL = "INSERT INTO POSITIONOVERRIDE (BUCKETID, BUCKETDISPNTYPE, EQUIPMENTID,RTSLOCATION,MODIFIEDDATETIME,STATUS,CONTACTNAME) " & _
                   "VALUES ('" & rsbcktexcep.Fields.Item("BUCKETID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("BUCKETDISPNTYPE").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("EQUIPMENTID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("RTSLOCATION").Value & "', " & _
                           " sysdate ," & _
                           "'" & rsbcktexcep.Fields.Item("STATUS").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("CONTACTNAME").Value & "') "
                  str = ReturnCdasXML(StrXml, strInsertSQL)
                  SQL_Execute (str)
   .MoveNext
    Loop
    End With
    cmdUpdateBucketExcep.Enabled = False
    msgbox"Data successfully updated"
ErrorHandler:
   

Endsub


Thanks,
NA

One thing you can do is to add this private type.


Option Explicit
Private Type anErr
    anErr As Integer
    anDescription As String
End Type
Private DBError As anErr

Public Function SQL_Execute(ByVal sXml As String) As Boolean

On Error GoTo ErrorHandler

    Dim oData           As DataControl.CDataControl

    Set oData = New CDataControl

    SQL_Execute = oData.ExecuteSQL(sConnectString, sXml)

ExitFunction:
    Set oData = Nothing
    Exit Function

ErrorHandler:

    MsgBox "SQL_Execute::" & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & vbCrLf & "sConnectString: " & sConnectString & vbCrLf & vbCrLf & "sXML: " & sXml

   DBError.anErr = Err.Number
   DBError.anDescription = Err.Description

    Resume ExitFunction
   

End Function

' And then some place in your code
If DBError.anErr <> 0 Then
    Msgbox DBError.anErr & ":" & DBError.Description
End if

Do i need to add this to code in vb form

i did following

Private Sub cmdUpdateBucketExcep_Click()

Dim strInsertSQL As String
Dim strUpdateSQL As String
Dim StrXml As String
Dim str As String


'If dgBucketExcepOriginal.Visible = False Then
'If getCurrRS Is Nothing Then
With rsbcktexcep
   .MoveFirst
    Do While Not .EOF
       
            strInsertSQL = "INSERT INTO FW_CUSTOM.RTSDISPOSITIONOVERRIDE (BUCKETID, BUCKETDISPNTYPE, EQUIPMENTID,RTSLOCATION,MODIFIEDDATETIME,STATUS,CONTACTNAME) " & _
                   "VALUES ('" & rsbcktexcep.Fields.Item("BUCKETID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("BUCKETDISPNTYPE").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("EQUIPMENTID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("RTSLOCATION").Value & "', " & _
                           " sysdate ," & _
                           "'" & rsbcktexcep.Fields.Item("STATUS").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("CONTACTNAME").Value & "') "
                  str = ReturnCdasXML(StrXml, strInsertSQL)
                  SQL_Execute (str)
   .MoveNext
    Loop
    End With
    cmdUpdateBucketExcep.Enabled = False
   
If DBError.anErr <> 0 Then
    'MsgBox DBError.anErr & ":" & DBError.Description
    MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description
    Else
    MsgBox "Data successfully updated"
End If
Endsub

What happened when you did that?

it throws error at DBError    Variable not defined..

Did you add these lines in the same module as your other code?

Option Explicit
Private Type anErr
    anErr As Integer
    anDescription As String
End Type
Private DBError As anErr

If you added the code but not in the same module then change Private to Public in the two places above.

I changed i t to public now it says:

cannot defined a public user-defined type with in a private object module.

Okay sorry. Put the two definitions as Private in the same module as your code.

that went through but

DBError.anErr = Err.Number   here its giving me error again...Overflow

Change

anErr As Integer

to

anErr As Long

It worked. Thanks Martin.

I really appreciate your patience. Have wonderful weekend ahead.

You're welcome and I'm glad I was able to help. (You won't forget to rate this I hope)

My profile contains links to some articles I've written that may interest you.
Marty - MVP 2009 to 2012

Hi Martin,
even though it was able to capture the error DBError.anErr <> 0 is never satisfied ., it is executing else at all times.

If DBError.anErr <> 0 Then
    'MsgBox DBError.anErr & ":" & DBError.Description
    MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description
    Else
    MsgBox "Data successfully updated"
End If


NA

Private Sub cmdUpdateBucketExcep_Click()

Dim strInsertSQL As String
Dim strUpdateSQL As String
Dim StrXml As String
Dim str As String


'If dgBucketExcepOriginal.Visible = False Then
'If getCurrRS Is Nothing Then
With rsbcktexcep
   .MoveFirst
    Do While Not .EOF
       
            strInsertSQL = "INSERT INTO FW_CUSTOM.RTSDISPOSITIONOVERRIDE (BUCKETID, BUCKETDISPNTYPE, EQUIPMENTID,RTSLOCATION,MODIFIEDDATETIME,STATUS,CONTACTNAME) " & _
                   "VALUES ('" & rsbcktexcep.Fields.Item("BUCKETID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("BUCKETDISPNTYPE").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("EQUIPMENTID").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("RTSLOCATION").Value & "', " & _
                           " sysdate ," & _
                           "'" & rsbcktexcep.Fields.Item("STATUS").Value & "', " & _
                           "'" & rsbcktexcep.Fields.Item("CONTACTNAME").Value & "') "
                  str = ReturnCdasXML(StrXml, strInsertSQL)
                SQL_Execute (Str)
               If DBError.anErr <> 0 Then
                    'MsgBox DBError.anErr & ":" & DBError.Description
                    MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description
                    Exit Do ' Maybe Exit Sub
                Else
                    MsgBox "Data successfully updated"
                End If

   .MoveNext
    Loop
    End With
    cmdUpdateBucketExcep.Enabled = False
   
End sub

It's still same thing , DBError.anErr  is 0 all time.

Code :

1) ModLib.bas

  Public Type anErr
    anErr As Long
    anDescription As String
End Type
Public DBError As anErr


Public Function SQL_Execute(ByVal sXml As String) As Boolean

On Error GoTo ErrorHandler

    Dim oData           As DataControl.CDataControl

    Set oData = New CDataControl

    SQL_Execute = oData.ExecuteSQL(sConnectString, sXml)

ExitFunction:
    Set oData = Nothing
    Exit Function

ErrorHandler:

  'MsgBox "SQL_Execute::" & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & vbCrLf & "sConnectString: " & sConnectString & vbCrLf & vbCrLf & "sXML: " & sXml
   DBError.anErr = Err.Number
   DBError.anDescription = Err.Description
   Resume ExitFunction

End Function



2.)  MainForm.frm

Private Type anErr
    anErr As Long
    anDescription As String
End Type
Private DBError As anErr

Private Sub cmdUpdateBucketExcep_Click()

Dim strInsertSQL As String
Dim strUpdateSQL As String
Dim StrXml As String
Dim str As String

Dim StrStatus As String

With rsbcktexcep
   .MoveFirst
      Do While Not .EOF
       
            strInsertSQL = "XXXXXX "
            str = ReturnCdasXML(StrXml, strInsertSQL)
            SQL_Execute (str)
           
           
             If DBError.anErr <> 0 Then
                    'MsgBox DBError.anErr & ":" & DBError.Description
                    'MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description
                    Dim strErr As String
                    strErr = True
                    Exit Do ' Maybe Exit Sub
                Else
                    MsgBox "Data successfully updated"
                End If
                 
     .MoveNext
    Loop
    End With
   
    cmdUpdateBucketExcep.Enabled = False
   

End Sub

Put a breakpoint on the line I bolded. Does the code get there?

ErrorHandler:

  'MsgBox "SQL_Execute::" & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & vbCrLf & "sConnectString: " & sConnectString & vbCrLf & vbCrLf & "sXML: " & sXml
   DBError.anErr = Err.Number
   DBError.anDescription = Err.Description
   Resume ExitFunction

If you can could you please attach your code so I can see the whole project.

Why is this line commented????


           If DBError.anErr <> 0 Then
                    'MsgBox DBError.anErr & ":" & DBError.Description
                    'MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description
                    Dim strErr As String
                    strErr = True
                    Exit Do ' Maybe Exit Sub

DBError.Description     . Error : method or datamember not defined . i am getting this error in form.i will attach file
frmMain.frm
modLib.bas

It should be  DBError.anDescription

Martin,

I un commented that line ,

  MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.Description

Change it to

MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.anDescription

i could see the following in debugger

?DBError.anErr
-2147220501

?DBError.anDescription
DataAccess error - An error has occured in DataAccess. Please check the event log of the host system for further detail.

but dont know why its reading 0 in form

I believe I see the problem. I used the same name twice!

Change

Private Type anErr
    anErr As Integer
    anDescription As String
End Type

to

Private Type anError
    anErr As Integer
    anDescription As String
End Type
Private DBError As anError

i made those changes did not makee any difference.

i declared anError As Long , because its throwing overflow exception .

I don't know what's going on. I tested my method with this code (it needs a project with a command button) and it works.
And I'm sorry to have to ask but could you please make a zip file from your complete project and attach that?

Option Explicit
Private Type anError
    anErr As Integer
    anDescription As String
End Type
Private DBError As anError

Private Sub Command1_Click()
    Dim x As Integer
    Do
        x = x + 1
        MySub x
        If DBError.anErr <> 0 Then
            MsgBox DBError.anErr & ":" & DBError.anDescription
            Exit Do
        End If
    Loop
End Sub

Public Sub MySub(intVal As Integer)

    Dim intTest As Integer
    
    On Error GoTo ErrorRoutine

    ' When intVal becomes 1000, a division by 0 error should happen
    intTest = 10 / (intVal - 1000)
    
    Exit Sub

ErrorRoutine:

    DBError.anErr = Err.Number
    DBError.anDescription = Err.Description

End Sub

Select allOpen in new window

Okay here's the real error:) You have both this in frmMain

Private Type anErr
    anErr As Long
    anDescription As String
End Type
Private DBError As anErr

Select allOpen in new window

and this in modLib

Public Type anErr
    anErr As Long
    anDescription As String
End Type
Public DBError As anErr

Select allOpen in new window

so remove the one from the form. I would also change the definition in the one in modLib to this as I suggested above, but apparently it works the way it is.

Public Type anError
    anErr As Long
    anDescription As String
End Type
Public DBError As anError

Select allOpen in new window

Ok . I changed . Is this correct? ..still debugger says 0

ModLib :


Public Type anError
    anErr As Long
    anDescription As String
End Type
Public DBError As anError


in form :

Private Type anErr
    anErr As Long
    anDescription As String
End Type
Private DBError As anErr




Code In form :

If DBError.anErr <> 0 Then
                   
                    MsgBox "Data Update Failed" & vbCrLf & DBError.anErr & ":" & DBError.anDescription
                    Dim strErr As String
                    strErr = True
                    Exit Do ' Maybe Exit Sub
                Else
                    MsgBox "Data successfully updated"
                End If

Martin,

Finally rsolved. Thanks for your great patience.

NA.

Great Work

You're welcome and I'm glad I was able to help.

My profile contains links to some articles I've written that may interest you.
Marty - MVP 2009 to 2012