SelTop query

[Mandy Medcraft]

Hi

I am using Access 2003 - any help very much appreciated, I seem to be going nowhere with this!!!

I am using Stephen Lebans Seltop code to hold the cursor position after requery. I have 2 continuous subforms (Child 143 and Shifts Allocate)embedded into the main form (Shifts NP), the SelTop code runs ok on the Top form but always fails on the top row of the Second form (runtime error 2101)... but only if the top row is the first row to be edited, subsequently it works fine? I have noted below where the code fails. [** moderator edit: see line 119 **]

Thanks MM

Option Compare Database
Option Explicit
' Our class to hold a couple of Public vars
Private SR As clsSetRow
Dim Ins As Boolean
 
 
Sub CLOSE_BUTTON_Click()
On Error GoTo Err_CLOSE_BUTTON_Click
 
 
    DoCmd.CLOSE
 
Exit_CLOSE_BUTTON_Click:
    Exit Sub
 
Err_CLOSE_BUTTON_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_CLOSE_BUTTON_Click
 
End Sub
 
Sub Combo51_AfterUpdate()
    ' Find the record that matches the control.
    Me.RecordsetClone.FindFirst "[W/E] = '" & Me![Combo51] & "'"
    Me.Bookmark = Me.RecordsetClone.Bookmark
End Sub
 
Private Sub EMPLOYEE_ID_BeforeUpdate(Cancel As Integer)
    Combo96.SetFocus
End Sub
 
Private Sub CLIENT_INVOICE_ID_AfterUpdate()
DoCmd.RunCommand acCmdRefresh
End Sub
 
 
Private Sub Combo96_BeforeUpdate(Cancel As Integer)
DoCmd.SetWarnings (False)
 
    Dim stDocName As String
    Dim stLinkCriteria As String
    Dim rsc As DAO.Recordset
 
    Set rsc = Me.RecordsetClone
 
    stLinkCriteria = "[Combo96]=" & "'" & "[EMPLOYEE ID], QSHIFT3" & "'"
 
        'Check QSHIFT2 query for duplicate Employee
 
    DoCmd.SetWarnings (True)
    Set rsc = Nothing
 
    If (DLookup("[Employee ID]", "QSHIFT3", "[EMPLOYEE ID]= '" & Me![Combo96] & "' AND (((#" & Me![FROM] & "#>=[FROM TIME]AND #" & Me![FROM] & "#<[TO TIME])OR (#" & Me![TO] & "#>[FROM TIME]AND #" & Me![TO] & "#<=[TO TIME]))OR ((#" & Me![FROM] & "#<[FROM TIME]AND #" & Me![TO] & "#>[TO TIME])))AND [W/E]=#" & Format(Me![W/E], "mm/dd/yy") & "# AND [X6]='" & Me![X6] & "'")) > 0 Then
 
        'Undo duplicate entry Removed BY MM - Me.Undo
 
        'Message box warning of duplication
        MsgBox "Warning Employee is already working.", vbCritical
        Exit Sub
    End If
 
End Sub
 
Private Sub Form_AfterInsert()
  Ins = False
 
End Sub
 
 
Private Sub Form_AfterUpdate()
 
Dim OrigSelTop As Long
Dim RowsFromTop As Long
Dim OrigCurrentSectionTop As Long
 
' Must cache the current props because Requery will
' reset them
OrigSelTop = SR.SelTop
OrigCurrentSectionTop = SR.CurrentSectionTop
 
' Turn off screen redraw
Me.Painting = False
 
' Requery the Form
Forms![shifts np].[Child143].Form.Requery
Forms![shifts np].[shifts allocate].Form.Requery
 
' Calculate how many rows, if any, the selected
' row was from the top prior to the Requery
 
' Check if Section Top = 0
 
    If OrigCurrentSectionTop = 0 Then
 
    Forms![shifts np].[Child143].Form.Requery
    Forms![shifts np].[shifts allocate].Form.Requery
    Me.Painting = True
    Else
 
    RowsFromTop = (OrigCurrentSectionTop - Me.Section(acHeader).Height) / Me.Section(acDetail).Height
 
    End If
 
' Setting the SelTop property forces this row to appear
' at the top of the Form. We will subtract the number of rows
' required, if any, so that the original current row remains
' at the original position prior to the Requery.
' First set the current record to the last record.
' This is required due to the method that
' that the Access GUI manages the ScrollBar.
 
If Me.RecordsetClone.RecordCount = 0 Then
 
Forms![shifts np].[Child143].SetFocus 'sets the focus to "shifts Allocate"
 
Else
Me.SelTop = Me.RecordsetClone.RecordCount
CODE FAILS HERE
Me.SelTop = OrigSelTop - RowsFromTop 
DoEvents
Me.Painting = True
' Now setfocus back to the original row prior to the Requery
Me.RecordsetClone.AbsolutePosition = Me.CurrentRecord + RowsFromTop - 1
Me.Bookmark = Me.RecordsetClone.Bookmark
End If
 
If (DLookup("[CLIENT INVOICE ID]", "[Contracted Hours Query3]", "[CLIENT INVOICE ID]") = Me![CLIENT INVOICE ID]) And (DLookup("[WARNING]", "[Contracted Hours Query3]", "[WARNING]") = -1) Then
    MsgBox "Hours Exceed Contract, Authorisation Required", vbCritical + vbOKCancel, "Contract Check"
    Exit Sub
End If
 
End Sub
 
 
 
Private Sub Form_BeforeInsert(Cancel As Integer)
    Ins = True
End Sub
 
Private Sub Form_BeforeUpdate(Cancel As Integer)
' Display a message that says employee already working.
DoCmd.SetWarnings (False)
 
  If IsNull(Me![EMPLOYEE ID]) Or Me![EMPLOYEE ID] = "" Then
    MsgBox "PLEASE ENTER EMPLOYEE ID", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![W/E]) Or Me![W/E] = "" Then
    MsgBox "PLEASE ENTER W/E DATE", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![DATE1]) Or Me![DATE1] = "" Then
    MsgBox "PLEASE ENTER THE DATE", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![CLIENT INVOICE ID]) Or Me![CLIENT INVOICE ID] = "" Then
    MsgBox "PLEASE ENTER THE CLIENT ID", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![DESCRIPTION]) Or Me![DESCRIPTION] = "" Then
    MsgBox "PLEASE ENTER THE JOB DESCRIPTION", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![FROM TIME]) Or Me![FROM TIME] = "" Then
    MsgBox "PLEASE ENTER THE START TIME", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
  If IsNull(Me![TO TIME]) Or Me![TO TIME] = "" Then
    MsgBox "PLEASE ENTER THE FINISH TIME", vbExclamation
    DoCmd.CancelEvent
    Exit Sub
  End If
 
If ([Student Visa] = -1) = True Then
    MsgBox "Employee is working on a Student Visa - please check weekly shifts do not exceed 20 hours", vbCritical + vbOKCancel, "Employee Visa Check"
  End If
 
  If ([HOURS] > 12) = True Then
    MsgBox "Hours for this shift exceed 12 ...  please confirm", vbCritical + vbOKCancel, "Hours check"
  End If
 
If (DLookup("[CLIENT INVOICE ID]", "[ENR QUERY]", "[CLIENT INVOICE ID]") = (Me![CLIENT INVOICE ID])) And (DLookup("[enr1]", "[enr query]", "[enr1]") = (Me![Combo96])) Or (DLookup("[enr2]", "[enr query]", "[enr2]") = (Me![Combo96])) Or (DLookup("[enr3]", "[enr query]", "[enr3]") = (Me![Combo96])) Or (DLookup("[enr4]", "[enr query]", "[enr4]") = (Me![Combo96])) Or (DLookup("[enr5]", "[enr query]", "[enr5]") = (Me![Combo96])) Or (DLookup("[enr6]", "[enr query]", "[enr6]") = (Me![Combo96])) Or (DLookup("[enr7]", "[enr query]", "[enr7]") = (Me![Combo96])) Or (DLookup("[enr8]", "[enr query]", "[enr8]") = (Me![Combo96])) Or (DLookup("[enr9]", "[enr query]", "[enr9]") = (Me![Combo96])) Or (DLookup("[enr10]", "[enr query]", "[enr10]") = (Me![Combo96])) And Ins = True Then
    MsgBox "Employee not required by this Client", vbCritical + vbOKCancel, "Employee Status Check"
    DoCmd.CancelEvent
    Combo96.SetFocus
    Exit Sub
  End If
 
End Sub
 
 
 
 
Private Sub Form_Current()
 
If Not SR Is Nothing Then
    SR.SelTop = Me.SelTop
    SR.CurrentSectionTop = Me.CurrentSectionTop
End If
 
    If ([T/SHT] = "SENT") Or ([T/SHT] = "INV") Then
    Me.AllowEdits = False
  Else
    Me.AllowEdits = True
  End If
 
  DoCmd.RunCommand acCmdRefresh
 
End Sub
 
Private Sub Command141_Click()
On Error GoTo Err_Command141_Click
 
 
    DoCmd.CLOSE
 
Exit_Command141_Click:
    Exit Sub
 
Err_Command141_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_Command141_Click
 
End Sub
Private Sub Combo154_AfterUpdate()
    ' Find the record that matches the control.
    Dim RS As Object
 
    Set RS = Me.Recordset.Clone
    RS.FindFirst "[W/E] = #" & Format(Me![Combo154], "mm\/dd\/yyyy") & "#"
    If Not RS.EOF Then Me.Bookmark = RS.Bookmark
End Sub
 
 
 
Private Sub Form_Load()
Set SR = New clsSetRow
End Sub
 
Private Sub Form_Open(Cancel As Integer)
 
  DoCmd.RunMacro "Homecare Ceased Macro"
 
End Sub
 
Private Sub JOB_CODE_Label_DblClick(Cancel As Integer)
Forms![shifts np].Form.OrderBy = "[Description]"
Forms![shifts np].Form.OrderByOn = True
 
End Sub

[nico5038]

Much code, I would start with placing a break point (Click in the left ruler to get a brown dot) just before the error and continue there with F8 to single step through the statements. This will enable you to inspect the values of the variables (hover with your mouse pointer over the field). I expect that the calculation gives a negative value, but test and see.

Nic;o)

[NeoPa]

For more on Debugging in VBA follow this link.

[Mandy Medcraft]

Hi Nic

Thanks for your response. I've tested the values when I run the code from different row positions and get the following:

On the top subform for which runs ok

OriginalSelTop, RowsfromTop, OrigCurrentSectionTop
Row1 1 0 1380
Row2 2 1 1680
Row3 3 2 1980
Row4 4 3 2280

But from the lower subform, which falls over
Row1 1 10 3345
Row2 2 1 600
Row3 3 2 900
Row4 4 3 1200

I cannot prove that it returns to 1 0 300 for the first row after editing elsewhere because I have to reset the form after debug, so I am never able to view the values on the second edit, but I assume that it returns to 1 0 300 after the code has run from another row, because it only ever falls over if i requery from Row1 first.

Probably not explaining this terribly well,but would really appreciate it if anyone could help. I am using Ver 7 Stephen Lebans SetGetScrollbars and it all works great except for this random value.

Many thanks
Mandy

[nico5038]

Looks like an initialization problem in the code to me. Somewhere the RowsFromTop and OrigSelTop isn't reset when starting again.

The "blunt" solution is to change your code from:

Me.SelTop = OrigSelTop - RowsFromTop 
 

too:

if me.OrigSelTop = 1 then
   Me.Seltop = 0
else
   Me.SelTop = OrigSelTop - RowsFromTop 
endif
 

But basically the subtraction could be changed into:

Me.SelTop = OriginalSelTop - 1
 

As that's the netto effect as far as I can see from your dumped data.

Nic;o)