Avatar of CodingSucks
CodingSucks
 asked on

Error Handling in Vb6.0

HI,

how do access error from data acces layer to presentaion layer. If SQL query fails in DA layer ,  i want to display message in presenattion layer.

please help..

Thanks in Advance,
NA
Visual Basic Classic

Avatar of undefined
Last Comment
Martin Liss

8/22/2022 - Mon
Martin Liss

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 

Open in new window

CodingSucks

ASKER
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
Martin Liss

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
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
CodingSucks

ASKER
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
Martin Liss

What happened when you did that?
CodingSucks

ASKER
it throws error at DBError    Variable not defined..
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Martin Liss

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.
CodingSucks

ASKER
I changed i t to public now it says:

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

Okay sorry. Put the two definitions as Private in the same module as your code.
Your help has saved me hundreds of hours of internet surfing.
fblack61
CodingSucks

ASKER
that went through but

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

Change

anErr As Integer

to

anErr As Long
CodingSucks

ASKER
It worked. Thanks Martin.

I really appreciate your patience. Have wonderful weekend ahead.
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Martin Liss

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
CodingSucks

ASKER
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
Martin Liss

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
I started with Experts Exchange in 2004 and it's been a mainstay of my professional computing life since. It helped me launch a career as a programmer / Oracle data analyst
William Peck
CodingSucks

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

ASKER
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
Martin Liss

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.
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Martin Liss

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
CodingSucks

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

It should be  DBError.anDescription
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23
CodingSucks

ASKER
Martin,

I un commented that line ,

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

Change it to

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

ASKER
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
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Martin Liss

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
CodingSucks

ASKER
i made those changes did not makee any difference.

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

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

Open in new window

Experts Exchange has (a) saved my job multiple times, (b) saved me hours, days, and even weeks of work, and often (c) makes me look like a superhero! This place is MAGIC!
Walt Forbes
Martin Liss

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

Open in new window


and this in modLib

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

Open 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

Open in new window

CodingSucks

ASKER
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
ASKER CERTIFIED SOLUTION
Martin Liss

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
CodingSucks

ASKER
Martin,

Finally rsolved. Thanks for your great patience.

NA.
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
CodingSucks

ASKER
Great Work
Martin Liss

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