Printable Version of Topic

Click here to view this topic in its original format

UtterAccess Forums _ Access Q and A _ How Do I Get An Error To Interrupt Code When I Have

Posted by: bobalston May 21 2020, 01:22 PM

How do i get an error to interrupt code when I have On Error Resume Next just before the offending line of code?

 

Posted by: theDBguy May 21 2020, 01:25 PM

Hi. Just a guess, but maybe you have your settings set to "break on all errors?"

Posted by: bobalston May 21 2020, 03:37 PM

Nope. Set to "break on unhandled errors".

Bob

Posted by: cheekybuddha May 21 2020, 03:48 PM

Hi, your error handler is hidden in the image.

I wonder whether the error that triggered the message box came from the prior call to Close the recordset.

Maybe post your whole procedure - there may be a better way to avoid the issue.

Posted by: bobalston May 22 2020, 02:37 PM

When I clicked on Debug, it highlighted the line of code as shown.

bob

Posted by: tina t May 22 2020, 04:48 PM

i'm with David - can we see the entire procedure, pls?

hth
tina

Posted by: bobalston May 22 2020, 07:52 PM

Public Function DownloadCMBHSData(dlnumber As String, startdate As String, EndDate As String, CMBHSid As String, CMBHSpassword As String)
Dim XMLConnectString As String

Dim XMLResponseText As String
Dim ResponseText As String
Dim FileName As String
Dim work As String
Dim strstartdate As String
Dim strenddate As String
'Cteate XML Input document
Dim xmldoc
Set xmldoc = CreateObject("Microsoft.xmldom")
Dim textt As String
Dim i As Long
Dim L As Long

startdate = startdate + "T00:00:00"
EndDate = EndDate + "T00:00:00"

DownloadCMBHSData = ""
'Create XML Response Document
Dim xmlresponse
Set xmlresponse = CreateObject("Microsoft.xmldom")

ResponseText = ""

' Get XML/Soap input string
Dim db As dao.Database ' Defines the current Access database
Dim INrec As dao.Recordset ' Defines the input records
Set db = CurrentDb
Set INrec = db.OpenRecordset("tbl_CMBHS_Download_Parms")
INrec.MoveFirst
XMLConnectString = INrec.fields("XMLInput")

' UPdate XML Connect String with dl#, from date and to date
'XMLConnectString = Replace(XMLConnectString, "##", Str(INrec.Fields(DLnumber)))

strstartdate = Replace(startdate, "/", "-")
strenddate = Replace(EndDate, "/", "-")

''' XMLConnectString = Replace(XMLConnectString, "##########", strstartdate, , 1)
''' XMLConnectString = Replace(XMLConnectString, "##########", strenddate, , 1)
XMLConnectString = Replace(XMLConnectString, "##########", strstartdate, , 1)
XMLConnectString = Replace(XMLConnectString, "$$$$$$$$$$", strenddate, , 1)

XMLConnectString = Replace(XMLConnectString, "##", dlnumber)

If Location = "1598" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">1598<", 1)
If Location = "406435" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">406435<", 1)
If Location = "406438" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">406438<", 1)
If Location = "446101" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">446101<", 1)
If Location = "2144" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">2144<", 1)
If Location = "449684" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">449684<", 1)
If Location = "449736" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">449736<", 1)
If Location = "449737" Then XMLConnectString = Replace(XMLConnectString, ">479<", ">449737<", 1)

' load XML/Soap document from string
xmldoc.loadxml (XMLConnectString)






'Create the xmlhttp object
'dim xlmlttp

' 7.26.2012 set as object
'Dim xmlhttp As Object

'''''''Set xmlhttp = CreateObject("MSxml2.serverXMLHTTP")
Set xmlhttp = CreateObject("Msxml2.ServerXMLHTTP.3.0")

On Error GoTo 0
' milleseconds 1800000=30 min
' milleseconds 2700000=45 min
' milleseconds 3600000=60 min
' prior to 7-11-2012 setting was 30 minutes
' 7-11-2012 setting changed to 60 minutes
' 7-26-2012 setting changed to 30 minutes
' 8-2-2012 changed last parm to 45 min
'''''xmlhttp.setTimeouts 3600000, 3600000, 3600000, 5400000
'''' 5/2/2013 changed timeout to 20 minutes
''xmlhttp.setTimeouts 3600000, 3600000, 3600000, 2400000 ' changed to below May 19, 2020
xmlhttp.setTimeouts 300000, 300000, 300000, 300000

'Open a connection and send a request to the server in the form of an XML fragment
'''''Call xmlhttp.Open("POST", "http://cmbhstrn.dshs.state.tx.us/cmbhswebservice/service/downloadservice.asmx", False)
''''' Call xmlhttp.Open("POST", "https://cmbhs.dshs.state.tx.us/cmbhswebservice/Service/DownloadService.asmx", False)
''''' Call xmlhttp.Open("POST", "https://cmbhslast.dshs.state.tx.us/cmbhswebservice.last1/Service/DataDownloadService.asmx", False) '' test 2018-03-14
' Call xmlhttp.Open("POST", "https://cmbhs.dshs.state.tx.us/cmbhswebservice/Service/DataDownloadService.asmx", False) ''' production 2018-04-04
Call xmlhttp.Open("POST", "https://cmbhs.dshs.state.tx.us/cmbhswebservice/Service/DataDownloadService.asmx", False) ' use db copy during bus hours
On Error GoTo errHandler


' Send XML/SOAP document
Call xmlhttp.Send(xmldoc)


'Create an xml document object, and load the server's response

Set xmlresponse = CreateObject("Microsoft.XMLDOM")
xmldoc.async = False

' Set response string with XML/Soap response
ResponseText = xmlhttp.ResponseText
'Note: the ResponseXml property parses the server's response, responsetext doesn't
'xmlresponse.setcontenttype = "text/xml"

On Error GoTo errHandler

xmlresponse.loadxml (xmlhttp.ResponseText)

x = xmlhttp.getResponseHeader("Content-type")



' modify the encoding spec in the response
L = Len(ResponseText)
i = InStr(ResponseText, "utf-8")
If i = 0 Then
textt = "UTF-8 NOT found in response text"
If Len(ResponseText) > 0 Then textt = textt + Chr$(13) + ResponseText
Call SendERRORemail(textt)
textt = Left$(textt, 254)
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt

Exit Function
End If
If i > 0 Then ResponseText = Left(ResponseText, i - 1) + "ISO-8859-1" + Mid(ResponseText, i + 5, L)




' check for password expiration - logic added 2012-12-9
i = 0
i = InStr(ResponseText, "[PasswordExpiration]")
If i > 0 Then
textt = "Password expiration notice received - CHANGE Password!"
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)

' stop processing
DoCmd.Quit
End If

' check for invalid password to avoid too many attempts and disabling the account - logic added 2012-12-9
i = 0
i = InStr(ResponseText, "Invalid User ID]")
If i > 0 Then
textt = "Invalid User ID or Password"
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)
' stop processing
DoCmd.Quit
End If



' Write ResponseText to File

FileName = "c:\CMBHS\download\xmldata" + Trim(Str(dlnumber)) + ".xml"


' Set result message
i = InStr(xmlhttp.ResponseText, "<DownloadResult>")
j = InStr(xmlhttp.ResponseText, "<Data>")
k = InStr(xmlhttp.ResponseText, "<Message>No data found</Message>")
If j = 0 Or (j - i) > 18 Then

If k > 0 Then
' no data returned by server
textt = "No data returned=" & xmlhttp.ResponseText
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
DownloadCMBHSData = "No data returned"
Exit Function
Else
textt = "No Message found in response TEXT=" & xmlhttp.ResponseText
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)
Call SendERRORemail(XMLConnectString)
Exit Function
End If
End If
'''''DownloadCMBHSData = Mid(xmlhttp.ResponseText, i + 9, Len(ResponseText)) 'captured the result = "transaction success." IF successful
DownloadCMBHSData = "Transaction success."

xmldoc.loadxml (ResponseText)
xmldoc.Save FileName





Exit Function

' Error Handler
errHandler:
If Err = -2146697205 Or Err = -2147012894 Then ' timeout
textt = "Timeout error" + " dl#= " + Str(dlnumber) + " loc= " + Location + " Startdate = " + Format(startdate)
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)
DownloadCMBHSData = "Error"
Exit Function
End If
If Err = -2146697208 Then ' timeout
textt = "Error -2146697208 No response received." + " dl#= " + Str(dlnumber) + " loc= " + Location + " Startdate = " + Format(startdate)
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)
DownloadCMBHSData = "Error"
Exit Function
End If

textt = "Error in receive XML - Err No " + Str(Err) + " " + Err.Description + " dl#= " + Str(dlnumber) + " loc = " + Str(Location) + "startdate = " + Format(startdate)

Call SendERRORemail(textt)
WriteHistory "DownloadCMBHSData ERROR!!!", " ", 0, 0, textt

Call SendERRORemail(textt)
DownloadCMBHSData = "Error"
Exit Function

errHandler2:

textt = "Error other than during D/L. " + Err.Number & ": " & Err.Description + " dl#= " + Str(dlnumber) + " loc= " + Location + " Startdate = " + Format(startdate)

WriteHistory "Process D/L CMBHS Data ERROR!!!", " ", 0, 0, textt
Call SendERRORemail(textt)
Exit Function
End Function

Posted by: tina t May 22 2020, 11:38 PM

hmm, am i missing something? i didn't find the smaller block of code that you originally posted, anywhere in the larger block of code that you last posted. if i managed to miss it even after looking three times, will you excuse these getting-older eyes and point it out to me, pls?

hth
tina

Posted by: bobalston May 23 2020, 12:18 PM

Oops. My apologies. I think the code below is correct:

CODE
Function AddEditPhone()
Dim i As Long

Dim Comments As String
Dim textt As String
Dim totalcnt As Integer
Dim ClientNumber As Long
Dim ClientPhoneNumber As String
Dim clientPhoneType As String
Dim AdmissionNumber As Long
Dim DischargeNumber As Long
Dim Screeningdate As Date
Dim FollowupNumber As Long
Dim update As Boolean
Dim RecordCreation, RecordUpdate As Date
Dim fieldname As String
Dim typeloc As String
Dim loccode As Integer
Dim myerr As String
Dim myerrdescr As String
Dim myclientnbr As Long


' Delete leftover imported tables
On Error Resume Next
   ' CurrentDb.TableDefs.Delete ("CMBHSAuthenticationHeader")
   ' CurrentDb.TableDefs.Delete ("Client")
   ' CurrentDb.TableDefs.Delete ("ClientContact")
   ' CurrentDb.TableDefs.Delete ("Comment")
   ' CurrentDb.TableDefs.Delete ("OrganizationClient")
   ' CurrentDb.TableDefs.Delete ("ServiceError")

   i = DeleteAllRecords("CMBHSAuthenticationHeader")
   i = DeleteAllRecords("Client")
   i = DeleteAllRecords("clientcontact")
   i = DeleteAllRecords("comment")
   i = DeleteAllRecords("organizationclient")
   i = DeleteAllRecords("serviceerror")
  


On Error GoTo Phone_error_Handler



    
Set rstdownloaded = New ADODB.Recordset
'Set rststats = New ADODB.Recordset
totalcnt = 0
update = False
rstdownloaded.Open ("SELECT * FROM ClientPhone"), CurrentProject.Connection, adOpenKeyset, , adCmdText
With rstdownloaded


Do Until .eof
    loccode = 0
    ClientNumber = 1000000000 + Val(.fields("clientNbr"))
    myclientnbr = ClientNumber
    
    
    ClientPhoneNumber = .fields("clientphonenbr")
    clientPhoneType = .fields("clientphonetype")
    
    '*** added 5/22/2012 To resolve occasional error ****
    On Error Resume Next
    rststats.Close
    Set rststats = Nothing
    Set rststats = New ADODB.Recordset
    On Error GoTo Phone_error_Handler
  
    '*****************************************************

    rststats.Open ("Select * FROM tbl_clientPhone " & _
       " WHERE [clientphonenbr] = '" & ClientPhoneNumber & "'" & "and  [clientphonetype] = '" & clientPhoneType & "'" & _
       " and [clientnbr] = " & Str(ClientNumber)), _
        CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect

    If Not rststats.eof Then
        If Val(ClientNumber) <> Val(rststats.fields("clientnbr")) Then
        
            textt = DataFile & "  Client numbers do not match - -  downloaded client_number = " & rstdownloaded.fields("clientnbr") & "  database client number = " & rststats.fields("client_number") & "Change not made."

            WriteHistory "Update Records ERROR!!!!!!!", "ClientPhone", 0, 0, textt
            Call SendERRORemail(textt)
            rststats.Close
            Set rststats = Nothing
            GoTo movenext
            End If
        
        
        '''''RSTstats.Edit   This is only used in DAO not in ADO which is what I am using
      
        Else
      
        rststats.AddNew
        
        End If
   On Error GoTo Phone_error_Handler
  
  If IsNull(rststats.fields("UpdatedDate")) Or .fields("Updateddate").Value > rststats.fields("UpdatedDate") Then
  
    loccode = 1
    rststats.fields("ClientPhoneNbr") = .fields("ClientPhonenbr").Value
      loccode = 2
    rststats.fields("ClientNbr") = ClientNumber
      loccode = 3
    rststats.fields("ClientPhonetype") = .fields("ClientPhoneType").Value
      loccode = 4
    rststats.fields("Phonenumber") = .fields("Phonenumber").Value
      loccode = 5
    rststats.fields("CreatedBy") = .fields("CreatedBy").Value
      loccode = 6
    rststats.fields("CreatedDate") = .fields("CreatedDate").Value
      loccode = 7
    rststats.fields("UpdatedBy") = .fields("UpdatedBy").Value
      loccode = 8
    rststats.fields("UpdatedDate") = .fields("Updateddate").Value
      loccode = 9
    rststats.update
    
    End If
    
    rststats.Close
    Set rststats = Nothing
    totalcnt = totalcnt + 1
    On Error GoTo Phone_error_Handler
movenext:
    .movenext
    Loop

End With


    textt = "Updated " & totalcnt & " total records"
    typeloc = "client phones" + Location
    WriteHistory "Add/Update Records", typeloc, 0, 0, textt
exitfunction:
    On Error Resume Next
    rststats.Close
    Set rststats = Nothing
    rstdownloaded.Close
    Set rstdownloaded = Nothing
Exit Function

Phone_error_Handler:

    If loccode > 0 Then
    
        myerr = Err
        myerrdescr = Err.Description
        textt = "Clientnumber=" + Str(myclientnbr) + "  err=" + myerr + " myerrdescr=" + myerrdescr + " loccode=" + Str(loccode)
        WriteHistory "Add/Update Phone", typeloc, 0, 0, textt
        Resume Next
        End If
  
   textt = "Error in loading Phone records.  Err = " & Err & "  Description = " & Err.Description & "  " & Str(ClientNumber) + "," + clientphonenbr + "," + clientPhoneType

  
   WriteHistory "Update Records ERROR!!!!!!!", "Client Phone", 0, 0, textt
   Call SendERRORemail(textt)
   GoTo exitfunction
  
      
End Function

Posted by: tina t May 23 2020, 01:17 PM

hi Bob, thanks for posting the code. i looked through it, but i'm finding it hard to follow, partly due to everything being inline (posting it in a code box might have helped with that), and also i'm not familiar with ADO so i'm not sure if that's contributing to my confusion. with one small exception, i think it better to wait to see if David - or anybody else with more experience - will take a whack at this. since it's a holiday weekend, maybe not until next week...

the one small exception is this line i noticed, as

Dim RecordCreation, RecordUpdate As Date

i think that RecordCreation is being dimmed as a Variant data type, not a Date data type. if that's what you intended, sorry - i'm just used to seeing the full declaration for each variable. also, if i'm wrong about the data type, i'm sure somebody will correct me. :)

hth
tina

Posted by: projecttoday May 23 2020, 06:41 PM

Re:

QUOTE
posting it in a code box might have helped with that

CODE
Function AddEditPhone()
Dim i As Long

Dim Comments As String
Dim textt As String
Dim totalcnt As Integer
Dim ClientNumber As Long
Dim ClientPhoneNumber As String
Dim clientPhoneType As String
Dim AdmissionNumber As Long
Dim DischargeNumber As Long
Dim Screeningdate As Date
Dim FollowupNumber As Long
Dim update As Boolean
Dim RecordCreation, RecordUpdate As Date
Dim fieldname As String
Dim typeloc As String
Dim loccode As Integer
Dim myerr As String
Dim myerrdescr As String
Dim myclientnbr As Long


' Delete leftover imported tables
On Error Resume Next
' CurrentDb.TableDefs.Delete ("CMBHSAuthenticationHeader")
' CurrentDb.TableDefs.Delete ("Client")
' CurrentDb.TableDefs.Delete ("ClientContact")
' CurrentDb.TableDefs.Delete ("Comment")
' CurrentDb.TableDefs.Delete ("OrganizationClient")
' CurrentDb.TableDefs.Delete ("ServiceError")

i = DeleteAllRecords("CMBHSAuthenticationHeader")
i = DeleteAllRecords("Client")
i = DeleteAllRecords("clientcontact")
i = DeleteAllRecords("comment")
i = DeleteAllRecords("organizationclient")
i = DeleteAllRecords("serviceerror")



On Error GoTo Phone_error_Handler




Set rstdownloaded = New ADODB.Recordset
'Set rststats = New ADODB.Recordset
totalcnt = 0
update = False
rstdownloaded.Open ("SELECT * FROM ClientPhone"), CurrentProject.Connection, adOpenKeyset, , adCmdText
With rstdownloaded


Do Until .eof
loccode = 0
ClientNumber = 1000000000 + Val(.fields("clientNbr"))
myclientnbr = ClientNumber


ClientPhoneNumber = .fields("clientphonenbr")
clientPhoneType = .fields("clientphonetype")

'*** added 5/22/2012 To resolve occasional error ****
On Error Resume Next
rststats.Close
Set rststats = Nothing
Set rststats = New ADODB.Recordset
On Error GoTo Phone_error_Handler

'*****************************************************

rststats.Open ("Select * FROM tbl_clientPhone " & _
" WHERE [clientphonenbr] = '" & ClientPhoneNumber & "'" & "and [clientphonetype] = '" & clientPhoneType & "'" & _
" and [clientnbr] = " & Str(ClientNumber)), _
CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect

If Not rststats.eof Then
If Val(ClientNumber) <> Val(rststats.fields("clientnbr")) Then

textt = DataFile & " Client numbers do not match - - downloaded client_number = " & rstdownloaded.fields("clientnbr") & " database client number = " & rststats.fields("client_number") & "Change not made."

WriteHistory "Update Records ERROR!!!!!!!", "ClientPhone", 0, 0, textt
Call SendERRORemail(textt)
rststats.Close
Set rststats = Nothing
GoTo movenext
End If


'''''RSTstats.Edit This is only used in DAO not in ADO which is what I am using

Else

rststats.AddNew

End If
On Error GoTo Phone_error_Handler

If IsNull(rststats.fields("UpdatedDate")) Or .fields("Updateddate").Value > rststats.fields("UpdatedDate") Then

loccode = 1
rststats.fields("ClientPhoneNbr") = .fields("ClientPhonenbr").Value
loccode = 2
rststats.fields("ClientNbr") = ClientNumber
loccode = 3
rststats.fields("ClientPhonetype") = .fields("ClientPhoneType").Value
loccode = 4
rststats.fields("Phonenumber") = .fields("Phonenumber").Value
loccode = 5
rststats.fields("CreatedBy") = .fields("CreatedBy").Value
loccode = 6
rststats.fields("CreatedDate") = .fields("CreatedDate").Value
loccode = 7
rststats.fields("UpdatedBy") = .fields("UpdatedBy").Value
loccode = 8
rststats.fields("UpdatedDate") = .fields("Updateddate").Value
loccode = 9
rststats.update

End If

rststats.Close
Set rststats = Nothing
totalcnt = totalcnt + 1
On Error GoTo Phone_error_Handler
movenext:
.movenext
Loop

End With


textt = "Updated " & totalcnt & " total records"
typeloc = "client phones" + Location
WriteHistory "Add/Update Records", typeloc, 0, 0, textt
exitfunction:
On Error Resume Next
rststats.Close
Set rststats = Nothing
rstdownloaded.Close
Set rstdownloaded = Nothing
Exit Function

Phone_error_Handler:

If loccode > 0 Then

myerr = Err
myerrdescr = Err.Description
textt = "Clientnumber=" + Str(myclientnbr) + " err=" + myerr + " myerrdescr=" + myerrdescr + " loccode=" + Str(loccode)
WriteHistory "Add/Update Phone", typeloc, 0, 0, textt
Resume Next
End If

textt = "Error in loading Phone records. Err = " & Err & " Description = " & Err.Description & " " & Str(ClientNumber) + "," + clientphonenbr + "," + clientPhoneType


WriteHistory "Update Records ERROR!!!!!!!", "Client Phone", 0, 0, textt
Call SendERRORemail(textt)
GoTo exitfunction


End Function

Posted by: tina t May 23 2020, 08:40 PM

hi Robert, and thanks, but i'm only assuming that Bob indents his code in the VBE. pasting it as straight text in UA loses that formatting. copying the straight text into a code box doesn't restore the original layout; your posted copy of the code looks just like Bob's posted code.

hth
tina

Posted by: projecttoday May 23 2020, 09:05 PM

Okay. I'm sorry for that.


Posted by: theDBguy May 23 2020, 11:52 PM

I added the code tags to the original post. Hope that helps...

Posted by: tina t May 24 2020, 10:00 AM

DBguy, thank you! :) tina

Posted by: cheekybuddha May 25 2020, 09:01 AM

Hi,

Just flying by, so haven't had time to digest all that code.

Since you are using ADODB recordsets, you can test that they are open before trying to close them:

CODE
' ...
    '*** added 5/22/2012 To resolve occasional error ****
'    On Error Resume Next
'    rststats.Close
'    Set rststats = Nothing
'    Set rststats = New ADODB.Recordset
'    On Error GoTo Phone_error_Handler
    If rststats.State = adStateOpen Then
      rststats.Close
    End If
' ...

Repeat for each instance.

I will need to look at this in more detail (no time at the moment frown.gif ), but I wouldn't be surprised if you could replace all of that code with a single query.

hth,

d