asked on

Sudden problem with ADO recordset in VB6 app

I have a VB6 app which is used as the basis for individually-modified apps for clients. It has worked fine for years, and I created a modified version a couple of months ago which also runs fine and was modified last week.

I created another clone this week, which appeared to be fine, but have since found that one recordset is not returning expected data (all others are fine). The code is unmodified from the original version, and I have tested the sql directly in Access.

I was originally using the rst twice (see line 401, marked This works fine), so I tried changing that to a new recordset. Made no difference to either bit of code.

I attach the code (some later sections removed, since its rather large) and some details. Can anyone suggest what I can try next?

The failing code is at line 481:

Private Sub ProcessData()

  Dim i As Integer, j As Integer
  Dim intPayrolls As Integer, intEmployees As Integer
  Dim intPeriods As Integer
  Dim intPension As Integer
  Dim intPensionScheme As Integer
  Dim intRecord As Integer, intElement As Integer, intValue As Integer, intTotalRecords As Integer
  Dim intAge As Integer
  Dim sngHours As Single
  Dim sngOvertimePremium As Single
  Dim dblEEPercentage As Double, dblERPercentage As Double, dblMatchPercentage As Double
  Dim dblEEAmount As Double, dblERAmount As Double, dblEELumpSum As Double, dblERMatchAmount As Double
  Dim dblERTopupAmount As Double, dblNISaveAmount As Double
  Dim dblEEBonusAmount As Double, dblERBonusAmount As Double
  Dim dblERBonusMatchAmount As Double, dblERBonusNISaveAmount As Double
  Dim dblValue As Double, dblValue2 As Double, dblEEGrossValue As Double, dblERGrossValue As Double
  Dim dblEEPenValue As Double, dblERPenValue As Double
  Dim dblSalary As Double, dblHourlyRate As Double
  Dim dblLEL As Double, dblET As Double, dblUEL As Double, dblNMW As Double
  Dim dblNIPercentage As Double, dblNISavingPercentage As Double
  Dim dblEeBonusPercentage As Double, dblErBonusPercentage As Double
  Dim dblSalaryCap As Double, dblEEMinPercentage As Double
  Dim strValue As String, strValue2 As String
  Dim strPayroll As String
  Dim strEmployee As String, strEmpStatus As String, strLeaverAfterRun As String
  Dim strEEPaycode As String, strERPaycode As String, strERMatchPaycode As String, strERTopupPaycode As String
  Dim strERNISavePaycode As String, strAVCPaycode As String, strEEBonusPaycode As String, strPayslipPaycode As String
  Dim strERBonusPaycode As String, strERBonusMatchPaycode As String, strERBonusNISavePaycode As String
  Dim strWarning As String
  Dim strSQl As String, strSQLValues As String, strSQLWhere As String
  Dim dtStart As Date, dtLeave As Date, dtDoB As Date
  Dim booFoundPension As Boolean, booSalaryExchange As Boolean, booAgeRelated As Boolean, booNIsaving As Boolean
  Dim booPension As Boolean, booSuspended As Boolean, booSMP As Boolean, booPHI As Boolean, booCourtOrder As Boolean
  Dim booBonus As Boolean, booSalaryCap As Boolean
  Dim rst As New ADODB.Recordset
  Dim rstPayrolls As New ADODB.Recordset
  Dim rstEEPensionableElements As New ADODB.Recordset
  Dim rstERPensionableElements As New ADODB.Recordset
  Dim rstEEGrossElements As New ADODB.Recordset
  Dim rstERGrossElements As New ADODB.Recordset
  Dim rstPHIElements As New ADODB.Recordset
  Dim rstBonusElements As New ADODB.Recordset
  Dim rstEmployees As New ADODB.Recordset
  Dim rstPensions As New ADODB.Recordset
  Dim rstOverrides As New ADODB.Recordset
  Dim rstAges As New ADODB.Recordset
  Dim rstEmpPensions As New ADODB.Recordset
  Dim strProcName As String
  
  strProcName = "ProcessData"
  On Error GoTo ProcessData_Error
  
  WriteLog "=========="
  WriteLog "Started Pension Calculation"

  '--- clear old data ---'
  SetStatusText "Clearing old data ..."
  cnnData.Execute "DELETE FROM tSystemCalculations"
  cnnData.Execute "DELETE FROM tUserCalculations"
  WriteLog "Cleared old data from tables"
  
  '--- check for payroll/s ---'
  rst.Open Source:="SELECT COUNT(*) FROM qPayrolls", _
           ActiveConnection:=cnnData, _
           CursorType:=adOpenForwardOnly, _
           LockType:=adLockReadOnly
  intPayrolls = rst.Fields(0)
  rst.Close
  If intPayrolls < 1 Then
    WriteInfo "No payrolls have been set up"
    GoTo ProcessData_Exit
  ElseIf intPayrolls > 1 Then
    Me.lblPayrolls.Caption = "of " & CStr(intPayrolls)
  End If
  
  '--- get general lookup info ---'
  rst.Open Source:="SELECT * FROM qMiscSettings", _
           ActiveConnection:=cnnData, _
           CursorType:=adOpenStatic, _
           LockType:=adLockReadOnly             ' this table has only 1 record
  dblLEL = rst.Fields("MonthlyLEL").Value
  dblUEL = rst.Fields("MonthlyUEL").Value
  dblNMW = rst.Fields("MonthlyNMW").Value      ' this is entered as monthly
  dblEeBonusPercentage = rst.Fields("EesBonusPercentage").Value
  dblErBonusPercentage = rst.Fields("ErsBonusPercentage").Value
  strEEBonusPaycode = Right("0" & CStr(rst.Fields("EesBonusPaycode").Value), 2)
  strERBonusPaycode = Right("0" & CStr(rst.Fields("ErsBonusPaycode").Value), 2)
  strERBonusMatchPaycode = Right("0" & CStr(rst.Fields("ErsBonusMatchPaycode").Value), 2)
  strERBonusNISavePaycode = Right("0" & CStr(rst.Fields("ErsBonusNISavePaycode").Value), 2)
  dblNIPercentage = rst.Fields("NIPercentage").Value
  dblNISavingPercentage = rst.Fields("NIFactorPercentage").Value
  dblSalaryCap = rst.Fields("MonthlySalaryCap").Value
  dblEEMinPercentage = rst.Fields("EEMinPercentage").Value
  rst.Close
  
  intTotalRecords = 0
  
  '--- process each payroll separately ---'
  rstPayrolls.Open Source:="SELECT * FROM qPayrolls", _
                   ActiveConnection:=cnnData, _
                   CursorType:=adOpenForwardOnly, _
                   LockType:=adLockReadOnly     ' 1 record / payroll
  rstPayrolls.MoveFirst
  
  Do While Not rstPayrolls.EOF
    
    intRecord = 0
    strPayroll = rstPayrolls.Fields("Payroll").Value
    intPeriods = rstPayrolls.Fields("Periods").Value
    strAVCPaycode = "00"      'rstPayrolls.Fields("LumpSumPaycode").Value
    strPayslipPaycode = "00"  'rstPayrolls.Fields("PayslipAccumulator").Value
    Me.txtPayroll.Text = strPayroll
    SetStatusText "Processing payroll " & strPayroll & " ..."

    '--- any data to process? ---'
    SetStatusText "Locating employee data ..."
    rst.Open Source:="SELECT COUNT(*) FROM tInputFixed " & _
                     " WHERE Payroll = '" & strPayroll & "'", _
             ActiveConnection:=cnnData, _
             CursorType:=adOpenForwardOnly, _
             LockType:=adLockReadOnly
    intEmployees = rst.Fields(0)
    Me.txtEmployees.Text = Trim(Str(intEmployees))
    rst.Close
    WriteInfo "Found " & Trim(Str(intEmployees)) & " employees to process for payroll " & strPayroll
    If intEmployees < 1 Then
      GoTo SkipThisPayroll
    End If
  
    '--- get lookup data ---'
    SetStatusText "Getting lookup details ..."
    rstEEPensionableElements.Open Source:="SELECT * FROM qEEPensionablePaycodes " & _
                                          " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                                  ActiveConnection:=cnnData, _
                                  CursorType:=adOpenStatic, _
                                  LockType:=adLockReadOnly
    If rstEEPensionableElements.RecordCount = 0 Then
      WriteInfo "No pay elements have been set as employees' pensionable for payroll " & strPayroll
      GoTo ProcessData_Exit
    End If
    rstEEPensionableElements.MoveFirst
    rstERPensionableElements.Open Source:="SELECT * FROM qERPensionablePaycodes " & _
                                          " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                                  ActiveConnection:=cnnData, _
                                  CursorType:=adOpenStatic, _
                                  LockType:=adLockReadOnly
    If rstERPensionableElements.RecordCount = 0 Then
      WriteInfo "No pay elements have been set as employer's pensionable for payroll " & strPayroll
      GoTo ProcessData_Exit
    End If
    rstERPensionableElements.MoveFirst
    rstEEGrossElements.Open Source:="SELECT * FROM qEEGrossPaycodes " & _
                                    " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                            ActiveConnection:=cnnData, _
                            CursorType:=adOpenStatic, _
                            LockType:=adLockReadOnly
    If rstEEGrossElements.RecordCount = 0 Then
      WriteInfo "No pay elements have been set as employees' gross pay for payroll " & strPayroll
      GoTo ProcessData_Exit
    End If
    rstEEGrossElements.MoveFirst
    rstERGrossElements.Open Source:="SELECT * FROM qERGrossPaycodes " & _
                                    " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                            ActiveConnection:=cnnData, _
                            CursorType:=adOpenStatic, _
                            LockType:=adLockReadOnly
    If rstERGrossElements.RecordCount = 0 Then
      WriteInfo "No pay elements have been set as employer's gross pay for payroll " & strPayroll
      GoTo ProcessData_Exit
    End If
    rstERGrossElements.MoveFirst
    rstPHIElements.Open Source:="SELECT * FROM qPHIPaycodes " & _
                                " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                        ActiveConnection:=cnnData, _
                        CursorType:=adOpenStatic, _
                        LockType:=adLockReadOnly
    If rstPHIElements.RecordCount = 0 Then
' This code removed, as PHI not required for this client
'      WriteInfo "No pay element has been set as PHI identifier for payroll " & strPayroll
'      GoTo ProcessData_Exit
    Else
      rstPHIElements.MoveFirst
    End If
    rstBonusElements.Open Source:="SELECT * FROM qBonusPaycodes " & _
                                  " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                        ActiveConnection:=cnnData, _
                        CursorType:=adOpenStatic, _
                        LockType:=adLockReadOnly
    If rstBonusElements.RecordCount = 0 Then
' This code removed, as bonuses not required for this client
'      WriteInfo "No pay element has been set as Bonus identifier for payroll " & strPayroll
'      GoTo ProcessData_Exit
    Else
      rstBonusElements.MoveFirst
    End If
    rstPensions.Open Source:="SELECT * FROM qAllPensions " & _
                             " WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
                     ActiveConnection:=cnnData, _
                     CursorType:=adOpenStatic, _
                     LockType:=adLockReadOnly
    If rstPensions.RecordCount = 0 Then
      WriteInfo "No pensions have been set up for payroll " & strPayroll
      GoTo ProcessData_Exit
    End If
    rstPensions.MoveFirst
  
    '--- start processing ---'
    rstEmployees.Open Source:="SELECT * FROM qInputFixed " & _
                              "WHERE Payroll = '" & strPayroll & "'", _
                      ActiveConnection:=cnnData, _
                      CursorType:=adOpenStatic, _
                      LockType:=adLockReadOnly
    ' we've already checked that there are employees in this payroll
    rstEmployees.MoveFirst
    Do While Not rstEmployees.EOF
    
      intRecord = intRecord + 1
      SetStatusText "Payroll " & strPayroll & ": processing record " & CStr(intRecord) & " of " & CStr(intEmployees)

      '--- get basic details ---'
      intPension = 0
      dblEEGrossValue = 0
      dblERGrossValue = 0
      dblEEPenValue = 0
      dblERPenValue = 0
      dblSalary = 0
      dblEEAmount = 0
      dblERAmount = 0
      dblEELumpSum = 0
      dblERMatchAmount = 0
      dblERTopupAmount = 0
      dblNISaveAmount = 0
      dblEEBonusAmount = 0
      dblERBonusAmount = 0
      dblERBonusMatchAmount = 0
      dblERBonusNISaveAmount = 0
      strEEPaycode = "00"
      strERPaycode = "00"
      strAVCPaycode = "00"
      strERMatchPaycode = "00"
      strERTopupPaycode = "00"
      strERNISavePaycode = "00"
      strWarning = ""
      booFoundPension = False
      booNIsaving = False
      booSalaryExchange = False
      booAgeRelated = False
      Me.txtEmployee.Text = rstEmployees.Fields("Shortname").Value
      strEmployee = rstEmployees.Fields("Employee").Value
      strEmpStatus = rstEmployees.Fields("FixEmpStatus").Value
      booSMP = ((strEmpStatus = "4") Or (strEmpStatus = "5"))
      booPHI = False
      strLeaverAfterRun = IIf(IsNull(rstEmployees.Fields("VarLeaverAfterRun").Value), "", rstEmployees.Fields("VarLeaverAfterRun").Value)
      booCourtOrder = False
      booPension = (rstEmployees.Fields("FixPensionFlg").Value = "1")
      booSalaryCap = False
'      booSuspended = (Left(rstEmployees.Fields("FixMiscSmallText01").Value, 1) = "2")
'      If booSuspended Then strWarning = strWarning & "Employee suspended. "
'      booPension = booPension And Not (booSuspended Or booSMP)
      'dblHourlyRate = IIf(rstEmployees.Fields("FixStandardHours").Value = "", 0, CDbl(rstEmployees.Fields("FixStandardHours").Value))
      dblHourlyRate = 0
      strValue = rstEmployees.Fields("FixStandardHours").Value
      If strValue <> "" Then dblHourlyRate = CDbl(strValue)
      
      '--- write basic details ---'
      strSQl = "INSERT INTO tSystemCalculations ("
      strSQLValues = " VALUES ("
      strSQl = strSQl & "Payroll, "
      strSQLValues = strSQLValues & "'" & strPayroll & "', "
      strSQl = strSQl & "Employee, "
      strSQLValues = strSQLValues & "'" & strEmployee & "', "
      strSQl = strSQl & "ShortName, "
      '--- fix for apostrophes ---'
      strValue = rstEmployees.Fields("ShortName").Value
      j = InStr(strValue, "'")
      If j > 0 Then
        strValue = Left(strValue, j - 1) & "''" & Mid(strValue, j + 1)
      End If
      strSQLValues = strSQLValues & "'" & strValue & "', "
      strSQl = strSQl & "NINo, "
      strSQLValues = strSQLValues & "'" & rstEmployees.Fields("FixNiNumber").Value & "', "
      strSQl = strSQl & "StartDate, "
      strValue = rstEmployees.Fields("FixStartDate").Value
      dtStart = CDate(strValue)
      strSQLValues = strSQLValues & "'" & strValue & "', "
      strValue = rstEmployees.Fields("FixLeavingDate").Value
      If strValue = "" Then
        dtLeave = CDate("01/01/2100")
        strSQl = Left(strSQl, Len(strSQl) - 2) & ")"
        strSQLValues = Left(strSQLValues, Len(strSQLValues) - 2) & ")"
      Else
        dtLeave = CDate(strValue)
        strSQl = strSQl & "LeaveDate)"
        strSQLValues = strSQLValues & "'" & strValue & "')"
      End If
      cnnData.Execute strSQl & strSQLValues
      strSQl = "INSERT INTO tUserCalculations ("
      strSQLValues = " VALUES ("
      strSQl = strSQl & "Payroll, "
      strSQLValues = strSQLValues & "'" & strPayroll & "', "
      strSQl = strSQl & "Employee, "
      strSQLValues = strSQLValues & "'" & strEmployee & "', "
      strSQl = strSQl & "PostToSPA) "
      strSQLValues = strSQLValues & "True)"
      cnnData.Execute strSQl & strSQLValues

      '--- not every employee has a pension ---'
      If booPension And _
         (dtStart < CDate(txtPeriodEnd.Text)) And _
         (dtLeave > CDate(txtPeriodStart.Text)) Then

        '--- get scheme details ---'
        strSQl = ""
        dblEEPercentage = 0
        dblERPercentage = 0
        dblMatchPercentage = 0
        rstEmpPensions.Open Source:="SELECT * FROM tInputPensions " & _
                                    " WHERE Payroll      = '" & strPayroll & _
                                    "'  AND Employee     = '" & strEmployee & _
                                    "'  AND FixPensnMemb = 'Y'" & _
                                    " ORDER BY Pension", _
                            ActiveConnection:=cnnData, _
                            CursorType:=adOpenForwardOnly, _
                            LockType:=adLockReadOnly
        ' we will assume that if the emp is in more than 1 pension, the first one is the right one
        Do While Not rstEmpPensions.EOF
          intValue = rstEmpPensions.Fields("Pension").Value
          rstPensions.MoveFirst
          Do While Not rstPensions.EOF
            strValue = rstPensions.Fields("Pension").Value
            If strValue = CStr(intValue) Then               ' this is the pension to use
              intPensionScheme = intValue
              strEEPaycode = Right("0" & rstPensions.Fields("EEPaycode").Value, 2)
              strERPaycode = Right("0" & rstPensions.Fields("ERPaycode").Value, 2)
              strERMatchPaycode = Right("0" & rstPensions.Fields("ERMatchPaycode").Value, 2)
              strERTopupPaycode = Right("0" & rstPensions.Fields("ERTopupPaycode").Value, 2)
              strERNISavePaycode = Right("0" & rstPensions.Fields("ERNISavePaycode").Value, 2)
              booAgeRelated = False
              If Not booAgeRelated Then
                dblEEPercentage = rstPensions.Fields("EEPercentage").Value
                dblERPercentage = rstPensions.Fields("ERPercentage").Value
                dblMatchPercentage = dblEEPercentage
              End If
              booNIsaving = rstPensions.Fields("NISaving").Value
              'booSalaryCap = rstPensions.Fields("SalaryCap").Value
              booFoundPension = True
              Exit Do
            End If
            If booFoundPension Then Exit Do
            rstPensions.MoveNext
          Loop
          If booFoundPension Then Exit Do
          rstEmpPensions.MoveNext
        Loop
        rstEmpPensions.Close
        If Not booFoundPension Then
          '--- delete the records ---'
          strSQl = "DELETE FROM tSystemCalculations "
          strSQl = strSQl & "WHERE Payroll  = '" & strPayroll & "'"
          strSQl = strSQl & "  AND Employee = '" & strEmployee & "'"
          cnnData.Execute strSQl
          strSQl = "DELETE FROM tUserCalculations "
          strSQl = strSQl & "WHERE Payroll  = '" & strPayroll & "'"
          strSQl = strSQl & "  AND Employee = '" & strEmployee & "'"
          cnnData.Execute strSQl
          '--- write to log ---'
          strValue = "not in pension scheme"
          WriteInfo "Processed employee " & strEmployee & ": no calculation because " & strValue
          '--- and don't do any more processing for this emp ---'
          'rstEmpPensions.Close
          GoTo SkipThisEmployee
        Else
          '--- get age-related pension info ---'
          If booAgeRelated Then
            rstAges.Source = "SELECT * FROM qAgePercentages " & _
                             " WHERE (Payroll = '" & strPayroll & "' OR Payroll = '0000')" & _
                             "   AND Pension  = " & CStr(intPensionScheme)
            rstAges.ActiveConnection = cnnData
            rstAges.CursorType = adOpenForwardOnly
            rstAges.LockType = adLockReadOnly
            rstAges.Open
            If rstAges.EOF Then
              WriteInfo ("Pension percentages have not been set up for scheme " & CStr(intPensionScheme))
              GoTo ProcessData_Exit
            End If
            rstAges.MoveFirst
            Do While Not rstAges.EOF
              If rstAges.Fields("MaxAge").Value > intAge Then
                dblEEPercentage = rstAges.Fields("EesPercentage").Value
                dblERPercentage = rstAges.Fields("ErsPercentage").Value
                dblMatchPercentage = dblEEPercentage
                Exit Do
              End If
              rstAges.MoveNext
            Loop
            rstAges.Close
          End If
          '--- check for overrides ---' only override 2 for this client
'>>> THIS WORKS FINE
          rstOverrides.Open Source:="SELECT * FROM tInputOverrides " & _
                           " WHERE (Payroll = '" & strPayroll & "' OR Payroll = '0000')" & _
                           "   AND Employee = '" & strEmployee & _
                           "'  AND Override = 2", _
                         ActiveConnection:=cnnData, _
                         CursorType:=adOpenForwardOnly, _
                         LockType:=adLockReadOnly
          Do While Not rstOverrides.EOF
            intValue = IIf(IsNull(rstOverrides.Fields("CompanyPensionSchemeNum").Value), 0, rstOverrides.Fields("CompanyPensionSchemeNum").Value)
            If intValue = intPensionScheme Then
              ' assume that if there is an override associated with the sal sac scheme,
              ' the scheme must be one where the employees can determine the %
              dblValue = IIf(IsNull(rstOverrides.Fields("Level1EmpPercentage").Value), 0, rstOverrides.Fields("Level1EmpPercentage").Value)
              dblValue2 = IIf(IsNull(rstOverrides.Fields("Level1ErsPercentage").Value), 0, rstOverrides.Fields("Level1ErsPercentage").Value)
              If (dblValue > 0) And (dblValue2 > 0) Then
                dblEEPercentage = dblValue
                dblERPercentage = dblValue2
                dblMatchPercentage = dblValue
              End If
            End If
            rstOverrides.MoveNext
          Loop
          rstOverrides.Close
          '--- check that percentages are available ---'
          If (dblEEPercentage = 0) And (dblERPercentage = 0) Then
            WriteInfo ("Pension percentages have not been completed for employee " & strEmployee)
            strWarning = strWarning & "Pension percentages have not been completed for employee "
            GoTo SkipThisEmployee 'ProcessData_Exit
          ElseIf dblEEPercentage = 0 Then
            WriteInfo ("Employee pension percentage has not been completed for employee " & strEmployee)
            strWarning = strWarning & "Employee pension percentage has not been completed for employee "
            GoTo SkipThisEmployee 'ProcessData_Exit
          ElseIf dblERPercentage = 0 Then
            WriteInfo ("Employer's pension percentage has not been completed for employee " & strEmployee)
            strWarning = strWarning & "Employer's pension percentage has not been completed for employee "
            GoTo SkipThisEmployee 'ProcessData_Exit
          End If
          '--- check NI Saving ---'
          If dblEEPercentage > dblEEMinPercentage Then
            booNIsaving = True
          End If
          '--- save the data ---'
          strSQl = "UPDATE tSystemCalculations "
          strSQl = strSQl & "SET PensionScheme        = " & CStr(intPensionScheme)
          strSQl = strSQl & "  , EePaycode            = " & strEEPaycode
          strSQl = strSQl & "  , ErPaycode            = " & strERPaycode
          strSQl = strSQl & "  , ErMatchPaycode       = " & strERMatchPaycode
          strSQl = strSQl & "  , ErTopupPaycode       = " & strERTopupPaycode
          strSQl = strSQl & "  , ErNISavePaycode      = " & strERNISavePaycode
          strSQl = strSQl & "  , EeBonusPaycode       = " & strEEBonusPaycode
          strSQl = strSQl & "  , ErBonusPaycode       = " & strERBonusPaycode
          strSQl = strSQl & "  , ErBonusMatchPaycode  = " & strERBonusMatchPaycode
          strSQl = strSQl & "  , ErBonusNISavePaycode = " & strERBonusNISavePaycode
          strSQl = strSQl & "  , EePercentage         = " & CStr(dblEEPercentage)
          strSQl = strSQl & "  , ErPercentage         = " & CStr(dblERPercentage)
          strSQl = strSQl & "  WHERE Payroll  = '" & strPayroll & "'"
          strSQl = strSQl & "    AND Employee = '" & strEmployee & "'"
          cnnData.Execute strSQl
        End If
        'rstEmpPensions.Close
        '--- sum the payments ---'
        strValue = rstEmployees.Fields("FixAnnualSalary").Value
        If strValue <> "" Then
          dblEEGrossValue = CDbl(strValue) / intPeriods
          dblERGrossValue = CDbl(strValue) / intPeriods
          dblSalary = CDbl(strValue) / intPeriods
        End If
        strValue = rstEmployees.Fields("FixStandardPay1").Value
        If strValue <> "" Then
          dblEEGrossValue = dblEEGrossValue + CDbl(strValue)
          dblERGrossValue = dblERGrossValue + CDbl(strValue)
        End If
        strValue = rstEmployees.Fields("FixStandardPay2").Value
        If strValue <> "" Then
          dblEEGrossValue = dblEEGrossValue + CDbl(strValue)
          dblERGrossValue = dblERGrossValue + CDbl(strValue)
        End If
        dblEEPenValue = dblEEGrossValue               ' all salary values are pensionable
        dblERPenValue = dblERGrossValue
'>>> THIS FAILS
        rst.Open Source:="SELECT * FROM tInputElements " & _
                         " WHERE Payroll  = '" & strPayroll & "' " & _
                         "   AND Employee = '" & strEmployee & "'", _
                 ActiveConnection:=cnnData, _
                 CursorType:=adOpenForwardOnly, _
                 LockType:=adLockReadOnly
        If rst.RecordCount > 0 Then
          rst.MoveFirst
          Do While Not rst.EOF
            '...
            rst.MoveNext
          Loop
        End If
        strSQl = "UPDATE tSystemCalculations SET"
        strSQl = strSQl & "  EEGrossPay = "
        strSQl = strSQl & Trim(Str(dblEEGrossValue))
        strSQl = strSQl & ", ERGrossPay = "
        strSQl = strSQl & Trim(Str(dblERGrossValue))
        strSQl = strSQl & ", EEPensionablePay = "
        strSQl = strSQl & Trim(Str(dblEEPenValue))
        strSQl = strSQl & ", ERPensionablePay = "
        strSQl = strSQl & Trim(Str(dblERPenValue))
        strSQl = strSQl & " WHERE Payroll = '" & strPayroll & "'"
        strSQl = strSQl & " AND Employee = '" & strEmployee & "'"
        cnnData.Execute strSQl
        rst.Close
        '...
      Else
        '...
      End If
SkipThisEmployee:
      rstEmployees.MoveNext
      DoEvents
    Loop

SkipThisPayroll:
    rstPayrolls.MoveNext
    DoEvents
  Loop
  
  '--- tidy up ---'
  SetStatusText "Finished processing"
  rstPayrolls.Close

ProcessData_Exit:
  Set rstPayrolls = Nothing
  Set rstEEPensionableElements = Nothing
  Set rstERPensionableElements = Nothing
  Set rstEEGrossElements = Nothing
  Set rstERGrossElements = Nothing
  Set rstEmployees = Nothing
  Set rstPensions = Nothing
  Set rstOverrides = Nothing
  Set rst = Nothing
  WriteInfo "----------"
  WriteInfo "Finished processing at " & CStr(Time)
  WriteInfo "=========="
  Exit Sub
ProcessData_Error:
  WriteInfo "Error " & Str(Err.Number) & ": " & Err.Description & " (" & strProcName & ")"
End Sub

Open in new window

Here are run and check details:

christinaemmm

ASKER

I have been able to do a workaround by changing
If rst.RecordCount > 0 Then
at line 487 to
If Not (rstElements.BOF And rstElements.EOF) Then

Curiouser and curiouser....

kbirecki

One noteable point about using rst.RecordCount is that you must execute rst.MoveLast before RecordCount will be populated, otherwise, it will return -1. I don't see that in your code, so it may have worked previously, or it may have sort-of worked and wasn't noticed, but I'm pretty confident that you need a MoveLast before a RecordCount is accurate.

One other possible underlying change may be Windows Updates that include updates to ADO versions. I'm not sure if changes in versions over time could have caused inconsistent behavior.

ASKER CERTIFIED SOLUTION

kbirecki

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

christinaemmm

ASKER

Hmm, thanks for that info - I did wonder about o/s updates as a cause, since I couldn't see any other possible change. I have been using recordcount because of the possibility of no data in some queries, which as I recall had caused errors when I did a movefirst. Can you suggest any safer way of checking at say, line 133?

christinaemmm

ASKER

Thanks for the confirmation

kbirecki

Thanks for the acceptance and points.

Regarding checking for no records, it can be done in different ways and "safer" might be relative. In your case, I'm guessing your backend server is MS SQL or something like that, so it should perform quite well. If it is something smaller like an Access database, for instance, you'd want to test to see what works best for you. Besides the BOF/EOF method we touched upon earlier, here is another option to determine if there are records before beginning any processing

Check record count or result set *before* connecting to record set for processing, i.e. do something like:

EPensionableElements.Open Source:="SELECT COUNT(Payroll) as RecCount FROM qEEPensionablePaycodes " & _
" WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
ActiveConnection:=cnnData, _
CursorType:=adOpenStatic, _
LockType:=adLockReadOnly

You'll get one record with a count of records, so then you'd do this:
EPensionableElements.MoveFirst
lRecCount = EPensionableElements!RecCount
EPensionableElements.Close '...or not, I don't think you'd normally have a problem starting a new recordset with the same variable without closing the first. The first is implicitly closed.
If lRecCount>0 then
'Then do something with a new recordset without the COUNT() function
EPensionableElements.Open Source:="SELECT * as RecCount FROM qEEPensionablePaycodes " & _
" WHERE Payroll = '" & strPayroll & "' OR Payroll = '0000'", _
ActiveConnection:=cnnData, _
CursorType:=adOpenStatic, _
LockType:=adLockReadOnly

Else
'Do something else....or not!
End if

The advantage of this is that some backend db's can do aggregations very quickly, and help you determine what to do if you will end up with a very large dataset.

Note: an additional improvement to the last query would be to explicitly name the fields instead of using "*", it performs slightly better that way.

There are other forms of queries that might provide multi-purpose/value in one query. For instance this page (http://www.techonthenet.com/sql/count.php) talks about using Distinct, Group By, etc. in various forms. Just thought I'd add that in case you hadn't run across using those ideas in similar circumstances.

christinaemmm

ASKER

Yes, I guess I could do that; its just a question of chucking some more code in. It is on Access - the whole thing is a failry small user app that has to run without attention. I'm going to have to go through it all soon anyway, as its to be ported to .net

Thanks for the help!