We help IT Professionals succeed at work.

VB Code to mark table for Employee Attendance

Trygve Thayer
on
673 Views
Last Modified: 2012-06-08
Database to keep records of employees attendance.

Table called..... tblOccurrence

Fields..........OccurrenceID                        Auto Number
...................Employee                             Text
...................Date                                     Date/Time
...................[Occurrence Value]                Long Integer
...................[Occurrence Type]                 Text
...................[Occurrence Comments]         Text
...................[Occurrence Dropped]             Yes/No
...................[Occurrence Reference]           Yes/No

Task

1. Check all records from the current date and mark the ones that are older than 1 year

2. Check all records in the current year and starting with the earliest date see if there is a span of more than 4 months
IF
    a span of 4 months is found and there are no records within the current year marked [Occurrence Reference]
    then mark the oldest record in the current year as dropped and mark the record the 4 month span was found.
    Ex.  If the date is 4/13/2004   and there are records of 4/15/2003, 5/15/2003, 8/11/2003,12/11/2003, and
    4/11/2004 in the current year  then there is a 4 month span between 8/11/2003 and 12/11/2003.  The
   4/15/2003 should be marked as [Occurrence Dropped] and 12/11/2003 should be marked as
   [Occurrence Reference]
Else
   a span of 4 months is found and there are records found within the current year marked [Occurrence Reference]
    then select all records in the current year from the latest record marked [Occurrence Reference] to the current
    date.  Recheck to see if there is a span of 4 months with no records.  If there is then mark the oldest record in
    the active year (1 year back) that is not marked as [Occurrence Dropped] and mark the 4 month span that was
    found.  Ex.  If the date is 4/13/2004   and there are records of 4/15/2003, 5/15/2003, 8/11/2003,12/11/2003,
    and 4/11/2004 in the current year and 4/15/2003 is marked as [Occurrence Dropped] and 8/11/2003 is marked
    [Occurrence Reference]  then there is a 4 month span between 12/11/2003 and 4/11/2004.  The
   5/15/2003 should be marked as [Occurrence Dropped] and 4/11/2004 should be marked as
   [Occurrence Reference]
Comment
Watch Question

Commented:
Hi Trygve,

I've seen the question and it will indeed take some time.
Puzzled why you mark all the rows matching a criteria as normally just using a query with a WHERE is just doing what you need.

But OK to give you a start you can create a set of two queries having the rows sequenced by a +1 incremented sequence number and one with the same sequence but starting with 2 instead of 1 (just use the same query but add +1 to the sequence field).
These two queries can be JOINed on Employee and that sequence field, thus giving you in one row the start and the enddate, allowing to calculate the duration you can test for the IF in your second point.

I'll have to look into the other things later (after my dinner)

Nic;o)
Trygve ThayerIT Director

Author

Commented:
I will do what ever you recommend as I am truely a novice with an HR manager expecting results.  My forte is in networking and not in databases.  Being short staffed here I am now going to heve to get up to speed on databases.  Thank goodness for the experts here to help me through.
Alan WarrenApplications Developer

Commented:
Hi Ty,

Need some clarification on this bit mate.
I dont need you to re-write it, just define the bits in question, just about got it memorised,
if you re-write it I'm back where I started from trying to get my head around this logic :)

2. Check all records in the current year and starting with the earliest date see if there is a span of more than 4 months
IF

            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.

Definitions:
Current Year = Every record  for one given Employee between TodaysDate and (Todaysdate - 1 year)  
                      aka (ActiveSet)
Current Year = Every record for one given Employee that is not marked dropped
                      (all recs > 1yr old are dropped prior to running this script)

Clarify this:
   ' and mark the record the 4 month span was found
    what do I mark?
    Define: 'the record'
    Suppose I find two records with a datediff > 4 months 1-aug-2003 and 2-dec-2003 which one do I mark
    and which field  am I marking [Occurrence Reference] or [Occurrence Dropped]

Notes:

The rule about only having a maximum of 3 [Occurrence Dropped] as a reward for perfect attendance in any given year, can only be attained if we check for  datediff => 4 months instead of  datediff > 4 months

The Attendance Policy Document seems less complex than this:

If perfect attendance is achieved (4 months without an occurence) Then
  find the oldest occurence for that employee that is not marked as dropped  
  and mark it as dropped,  (all recs > 1yr old are dropped prior to running this script)
 
End If

Occurence Reference field may not be needed at all...

Alan




Alan WarrenApplications Developer

Commented:
Hi Ty,

Sorry I didn't get this done last night, stuff happens.

Got no problem finding qualifying occurences with the correct datediff - done

This where I am up to:
Clarification requested above pertains to this point in code:
              ' Found between OccurrenceID 23 and OccurrenceID 23
              Stop


Private Sub Command13_Click()
  On Error GoTo ReportError
 
  Dim strSQL As String
  Dim strWhere As String
  Dim strFilesChecked As String   ' InClause for sql where condition
                                  ' (records to exclude on next loop of active set)
 
  Dim recOccurrence As ADODB.Recordset
  Dim recEmployee As ADODB.Recordset
  Dim dNextNewestDate As Date
  Dim dNextOldestDate As Date
  Dim lNextOldestID As Long
  Dim lNextNewestID As Long
 
  ' 1. -The update should check all records and mark the field
  ' [Occurrence Dropped] if the records are older than 1 year.
  strSQL = "UPDATE tblOccurrence SET tblOccurrence.[Occurrence Dropped] = True"
  strSQL = strSQL & " WHERE [Date] <=DateAdd('yyyy',-1,Now())"
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True

'2. Check all records in the current year and starting with the earliest date
'   see if there is a span of more than 4 months

  Set recOccurrence = New ADODB.Recordset
  Set recEmployee = New ADODB.Recordset

  strSQL = "SELECT Distinct tblOccurrence.Employee FROM tblOccurrence"
  recEmployee.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recEmployee
    .MoveFirst
    Do While Not .BOF And Not .EOF
      Do
        ' open the active set for this employee
        strSQL = "SELECT OccurrenceID, Employee, [Date], [Occurrence Dropped], [Occurrence Reference] FROM tblOccurrence"
        strSQL = strSQL & " WHERE Employee='" & .Fields("Employee")
        strSQL = strSQL & "' AND [Occurrence Dropped]=False"
        ' Exclude ID's in this active set that we have already checked
        If strFilesChecked <> "" Then
          strSQL = strSQL & " AND OccurrenceID Not IN(" & Left(strFilesChecked, Len(strFilesChecked) - 1) & ")"
        End If
       
        strSQL = strSQL & " Order By Date Asc"
        recOccurrence.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        With recOccurrence
          .MoveFirst

          If Not .BOF And Not .EOF Then
            lNextOldestID = .Fields("OccurrenceID")
            dNextOldestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            .MoveNext
            lNextNewestID = .Fields("OccurrenceID")
            dNextNewestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.
            If dNextOldestDate < DateAdd("m", -4, dNextNewestDate) Then
              ' a span of 4 months has been found
              ' Found between OccurrenceID 23 and OccurrenceID 23
              Stop
              '  then mark the oldest record in the current year as dropped
              '  and mark the record the 4 month span was found.
              '  Of the two records we are comparing, which record gets marked as
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????
             
              '  ==========================================
              '  Code to mark the oldest occurence, in current year, not marked as dropped,
              '  for this employee goes here.
              '
              '  ==========================================
            Else
              ' Add the ID of this record to strFilesChecked(List of records to exclude on next loop)
              strFilesChecked = strFilesChecked & .Fields("OccurrenceID") & ","
            End If
          End If
          .Close
        End With
      Loop
      .MoveNext
    Loop
  End With
 
ExitProcedure:
  On Error Resume Next
  Set recOccurrence = Nothing
  Set recEmployee = Nothing
  Exit Sub

ReportError:
  Dim msg As String
  ' Modify the following to return correct Form Name and Procedure Name ********
  msg = "Error in Form1_Command11_Click():" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
End Sub


Alan
Trygve ThayerIT Director

Author

Commented:
allenwarren......

I pasted the code in and ran it.  From your comments I understood you still had some work to do on it.  I just wanted to see where it got.   It marked records as [Occurrence Dropped] but went in error which is what I guess you are still working on.  The code is below where I got the error.

If Not .BOF And Not .EOF Then
            lNextOldestID = .Fields("OccurrenceID")
            dNextOldestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            .MoveNext
            lNextNewestID = .Fields("OccurrenceID")
            dNextNewestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.
            If dNextOldestDate < DateAdd("m", -4, dNextNewestDate) Then
              ' a span of 4 months has been found
              ' Found between OccurrenceID 23 and OccurrenceID 23
*****    Stop
              '  then mark the oldest record in the current year as dropped
              '  and mark the record the 4 month span was found.
              '  Of the two records we are comparing, which record gets marked as
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????
Trygve ThayerIT Director

Author

Commented:
alanwarren.....


Just catching up and read some of your previous posts indicating the [Occurrence Reference] field might not be needed.  That works for me.  I could just not visualize how to describe it.

Also your comments from below referencing the attendance policy.  If in the sample data 4/15/2003 is marked dropped and it is dropped as a result of the 4 months between 8/11/2003 and 12/11/2003.  then is it possible there can be a 4 month period of good attendance that doesn't quality.  I am thinking that if the update has not been ran daily the situation could exist. which could cause more than 3 records to be dropped in 1 years time.  Don't know that for sure.

If perfect attendance is achieved (4 months without an occurence) Then
  find the oldest occurence for that employee that is not marked as dropped  
  and mark it as dropped,  (all recs > 1yr old are dropped prior to running this script)

and there are records of 4/15/2003, 5/15/2003, 8/11/2003,12/11/2003, and
    4/11/2004 in the current year
Alan WarrenApplications Developer

Commented:
G'Day Ty,
              ' pick up thought here:

              Stop
              '  then mark the oldest record in the current year as dropped       ------ Now Completed
             

              '  and mark the record the 4 month span was found.                   ------- huh???
              '  Of the two records we are comparing, which record gets marked as what
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????

Alan :)
Alan WarrenApplications Developer

Commented:


I think it should be:
   Mark Fields("Occurrence Reference") = true  for dNextNewestDate  field

Choose between the two date we are comparing

The only reason I see for keeping Fields("Occurrence Reference")  is so you can later query the records to report that because on this date Where Fields("Occurrence Reference")  = true
that the employee was granted a reward for perfect attendance
the reward being one of his/here blemishes has been removed from his/her history.

Alan
Trygve ThayerIT Director

Author

Commented:
As long as it works I am happy.  Have to go to a neighbors hose to fix their computer.  I guess I am the subdivisions technician.  Be back in 30 minutes.
Applications Developer
Commented:
Unlock this solution and get a sample of our free trial.
(No credit card required)
UNLOCK SOLUTION
Trygve ThayerIT Director

Author

Commented:
AllenWarren......

Got your post.  I have just been paged to take care of a network issue as a result of a power loss.  It is 9:50pm here.  I will be back in 3 hours and let you know how it works.  Thanks in advance for all your help.
Trygve ThayerIT Director

Author

Commented:
allenwarren.........

The 3 hours turned into almost an all nighter.  Tried your code this morning (your night) and it works exactly as expected.  Thanks so much for your help.  I will continue on developing the logistics of this database as occurrences are only one part.  I still have overtime and vacation to go but they are within my abilities (I think) If not, you will see me again (probably the case).  

P.S. Saw your ad for contract support.  Send me your requirements to tthayer@vacumet.com   There is nothing at the time but with projected goals for our department we might be able to work something out after October which is when budgets are reviewed.  We usually have a little left over and using it to get us off these aggrivating (macro intensive) Lotus Approach databases would be well worth managements consideration.
Trygve ThayerIT Director

Author

Commented:
allenwarren......testing found vb error messages.

The only records I had in our test data was for Trygve Thayer.  In doing some more testing I have added 1 more record which is a different employee.  It gives me this error message.

Error in frmOccurrenceCommand11_Click():  Error number 3705 was generated by ADODB.Recordset.  Operation is not allowed when the object is open.
Alan WarrenApplications Developer

Commented:
will check into it shortly mate...
Alan WarrenApplications Developer

Commented:

oops!
  had no Exit Do for recEmployee


Alan


Private Sub Command13_Click()
  On Error GoTo ReportError
 
  Dim strSQL As String
  Dim strWhere As String
  Dim strFilesChecked As String   ' InClause for sql where condition
                                  ' (records to exclude on next loop of active set)
 
  Dim recOccurrence As ADODB.Recordset
  Dim recEmployee As ADODB.Recordset
  Dim dNextNewestDate As Date
  Dim dNextOldestDate As Date
  Dim lNextOldestID As Long
  Dim lNextNewestID As Long
  Dim lRecordChecked As Long
 
  ' 1. -The update should check all records and mark the field
  ' [Occurrence Dropped] if the records are older than 1 year.
  strSQL = "UPDATE tblOccurrence SET tblOccurrence.[Occurrence Dropped] = True"
  strSQL = strSQL & " WHERE [Date] <=DateAdd('yyyy',-1,Now())"
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True

'2. Check all records in the current year and starting with the earliest date
'   see if there is a span of more than 4 months

  Set recOccurrence = New ADODB.Recordset
  Set recEmployee = New ADODB.Recordset

  strSQL = "SELECT Distinct tblOccurrence.Employee FROM tblOccurrence"
  recEmployee.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recEmployee
    .MoveFirst
    Do While Not .BOF And Not .EOF
      Do
        ' open the active set for this employee
        strSQL = "SELECT OccurrenceID, Employee, [Date], [Occurrence Dropped], [Occurrence Reference] FROM tblOccurrence"
        strSQL = strSQL & " WHERE Employee='" & .Fields("Employee")
        strSQL = strSQL & "' AND [Occurrence Dropped]=False AND [Occurrence Reference]=False"
        ' Exclude ID's in this active set that we have already checked
        If strFilesChecked <> "" Then
          strSQL = strSQL & " AND OccurrenceID Not IN(" & Left(strFilesChecked, Len(strFilesChecked) - 1) & ")"
        End If
       
        strSQL = strSQL & " Order By Date Asc"
        recOccurrence.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        With recOccurrence
          ' .MoveFirst                ' <-- aw 15-apr-2004 moved this down 2 lines
          If Not .BOF And Not .EOF Then
            .MoveFirst                ' <-- aw 15-apr-2004 modified positon of this line
            lNextOldestID = .Fields("OccurrenceID")
            lRecordChecked = lNextOldestID
            dNextOldestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            .MoveNext
           
            If .EOF Then: Exit Do
            lNextNewestID = .Fields("OccurrenceID")
            dNextNewestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.
            If dNextOldestDate <= DateAdd("m", -4, dNextNewestDate) Then
              ' a span of 4 months has been found
              '  then mark the oldest record in the current year as dropped
              '  and mark the record the 4 month span was found.
              '  Of the two records we are comparing, which record gets marked as
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????
             
              '  ==========================================
              '  Code to mark the oldest occurence, in current year, not marked as dropped,
              '  for this employee goes here.
              '
              '  note: Get the ID of oldest record not dropped for this Employee
              '        Then run some sql here to mark as dropped and re-populate the variable
              '  ==========================================
              strFilesChecked = strFilesChecked & .Fields("OccurrenceID") & ","
              Dim lOldestOffenceID As Long
              lOldestOffenceID = getOldestActiveOffenceID(.Fields("Employee"))
              Call doMarkOldestActiveOffenceID(lOldestOffenceID)
              Call doMarkOccurencReference(lNextNewestID)
             
            Else
              ' Add the ID of this record to strFilesChecked(List of records to exclude on next loop)
              strFilesChecked = strFilesChecked & lRecordChecked & ","
            End If
         
          Else     '<-- aw 15-apr-2004 Added the Else to get out of the inner loop if .BOF and .EOF
            .Close
            Exit Do
         
          End If
          .Close
        End With
      Loop
      strFilesChecked = ""
      .MoveNext
    Loop
  End With
 
ExitProcedure:
  On Error Resume Next
  Set recOccurrence = Nothing
  Set recEmployee = Nothing
  Exit Sub

ReportError:
  Dim msg As String
  msg = "Error in " & Me.Name & "Command11_Click():" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
End Sub
Trygve ThayerIT Director

Author

Commented:
allenwarren......

Still getting same error but attempted looking through it and think I found it but before I try changing it I wanted to run it by you.  I have marked it at the bottom with *****

Private Sub Command13_Click()
  On Error GoTo ReportError
 
  Dim strSQL As String
  Dim strWhere As String
  Dim strFilesChecked As String   ' InClause for sql where condition
                                  ' (records to exclude on next loop of active set)
 
  Dim recOccurrence As ADODB.Recordset
  Dim recEmployee As ADODB.Recordset
  Dim dNextNewestDate As Date
  Dim dNextOldestDate As Date
  Dim lNextOldestID As Long
  Dim lNextNewestID As Long
  Dim lRecordChecked As Long
 
  ' 1. -The update should check all records and mark the field
  ' [Occurrence Dropped] if the records are older than 1 year.
  strSQL = "UPDATE tblOccurrence SET tblOccurrence.[Occurrence Dropped] = True"
  strSQL = strSQL & " WHERE [Date] <=DateAdd('yyyy',-1,Now())"
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True

'2. Check all records in the current year and starting with the earliest date
'   see if there is a span of more than 4 months

  Set recOccurrence = New ADODB.Recordset
  Set recEmployee = New ADODB.Recordset

  strSQL = "SELECT Distinct tblOccurrence.Employee FROM tblOccurrence"
  recEmployee.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recEmployee
    .MoveFirst
    Do While Not .BOF And Not .EOF
      Do
        ' open the active set for this employee
        strSQL = "SELECT OccurrenceID, Employee, [Date], [Occurrence Dropped], [Occurrence Reference] FROM tblOccurrence"
        strSQL = strSQL & " WHERE Employee='" & .Fields("Employee")
        strSQL = strSQL & "' AND [Occurrence Dropped]=False AND [Occurrence Reference]=False"
        ' Exclude ID's in this active set that we have already checked
        If strFilesChecked <> "" Then
          strSQL = strSQL & " AND OccurrenceID Not IN(" & Left(strFilesChecked, Len(strFilesChecked) - 1) & ")"
        End If
       
        strSQL = strSQL & " Order By Date Asc"
        recOccurrence.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        With recOccurrence
          ' .MoveFirst                ' <-- aw 15-apr-2004 moved this down 2 lines
          If Not .BOF And Not .EOF Then
            .MoveFirst                ' <-- aw 15-apr-2004 modified positon of this line
            lNextOldestID = .Fields("OccurrenceID")
            lRecordChecked = lNextOldestID
            dNextOldestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            .MoveNext
           
            If .EOF Then: Exit Do
            lNextNewestID = .Fields("OccurrenceID")
            dNextNewestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.
            If dNextOldestDate <= DateAdd("m", -4, dNextNewestDate) Then
              ' a span of 4 months has been found
              '  then mark the oldest record in the current year as dropped
              '  and mark the record the 4 month span was found.
              '  Of the two records we are comparing, which record gets marked as
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????
             
              '  ==========================================
              '  Code to mark the oldest occurence, in current year, not marked as dropped,
              '  for this employee goes here.
              '
              '  note: Get the ID of oldest record not dropped for this Employee
              '        Then run some sql here to mark as dropped and re-populate the variable
              '  ==========================================
              strFilesChecked = strFilesChecked & .Fields("OccurrenceID") & ","
              Dim lOldestOffenceID As Long
              lOldestOffenceID = getOldestActiveOffenceID(.Fields("Employee"))
              Call doMarkOldestActiveOffenceID(lOldestOffenceID)
              Call doMarkOccurencReference(lNextNewestID)
             
            Else
              ' Add the ID of this record to strFilesChecked(List of records to exclude on next loop)
              strFilesChecked = strFilesChecked & lRecordChecked & ","
            End If
         
          Else     '<-- aw 15-apr-2004 Added the Else to get out of the inner loop if .BOF and .EOF
            .Close
            Exit Do
         
          End If
          .Close
        End With
      Loop
      strFilesChecked = ""
      .MoveNext
    Loop
  End With
 
ExitProcedure:
  On Error Resume Next
  Set recOccurrence = Nothing
  Set recEmployee = Nothing
  Exit Sub

ReportError:
  Dim msg As String
*************  msg = "Error in " & Me.Name & "Command11_Click():" _

********should the line above be Command13_Click():"     ?


    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
End Sub
Alan WarrenApplications Developer

Commented:
Hi


no thats not the problem, you could type anything in there, it is just a string,
but it should have the name of your button in there

Do you get a compile error?
In any code window Menu > Debug > Compile

Alan
Trygve ThayerIT Director

Author

Commented:
Well that was not it.   I went and tried it anyway but still get same error.
Alan WarrenApplications Developer

Commented:
Hi mate,

mine seems to be working as expected.


OccurrenceID      Employee      Date      Occurrence Value      Occurrence Type      Occurrence Comments      Occurrence Dropped      Occurrence Reference
1      Thayer, Trygve      10-Apr-2003      2      Call In      yep he did it.      Yes      No
5      Thayer, Trygve      30-Mar-2002      2      Call In            Yes      No
6      Thayer, Trygve      01-Jan-2001      2      Call In      tttt      Yes      No
7      Thayer, Trygve      01-Jan-2001      2      Call In      eeee      Yes      No
8      Thayer, Trygve      01-Jan-2002      1      Call In      wwww      Yes      No
9      Thayer, Trygve      01-Jan-2003      1      Call In      rrrr      Yes      No
10      Thayer, Trygve      02-Jan-1998      1      Call In            Yes      No
11      Thayer, Trygve      02-Jan-1999      1      Call In            Yes      No
12      Thayer, Trygve      02-Jan-2000      2      Call In            Yes      No
13      Thayer, Trygve      02-Jan-2001      1      Call In            Yes      No
14      Thayer, Trygve      02-Jan-2002      1      Call In            Yes      No
15      Thayer, Trygve      01-Feb-2003      1      Call In            Yes      No
16      Thayer, Trygve      01-Mar-2003      1      Call In            Yes      No
17      Thayer, Trygve      01-Apr-2003      1      Call In            Yes      No
18      Thayer, Trygve      15-May-2003      2      Over 2            Yes      No
19      Thayer, Trygve      11-Aug-2003      1      Over 2            Yes      No
23      Thayer, Trygve      11-Dec-2003      2      Call In            No      Yes
25      Thayer, Trygve      15-Apr-2003      1      Call In            Yes      No
27      Thayer, Trygve      12-Apr-2004      2      Call In            No      Yes
28      Warren, Alan      15-May-2003      2      Over 2            Yes      No
29      Warren, Alan      11-Aug-2003      1      Over 2            Yes      No
30      Warren, Alan      11-Dec-2003      2      Call In            No      Yes
31      Warren, Alan      15-Apr-2003      1      Call In            Yes      No
32      Warren, Alan      12-Apr-2004      2      Call In            No      Yes


Alan
Trygve ThayerIT Director

Author

Commented:
All I did was copy the files from the directory and added 1 record.  Here is the code I have and also the records.

Private Sub Command13_Click()
  On Error GoTo ReportError
 
  Dim strSQL As String
  Dim strWhere As String
  Dim strFilesChecked As String   ' InClause for sql where condition
                                  ' (records to exclude on next loop of active set)
 
  Dim recOccurrence As ADODB.Recordset
  Dim recEmployee As ADODB.Recordset
  Dim dNextNewestDate As Date
  Dim dNextOldestDate As Date
  Dim lNextOldestID As Long
  Dim lNextNewestID As Long
  Dim lRecordChecked As Long
 
  ' 1. -The update should check all records and mark the field
  ' [Occurrence Dropped] if the records are older than 1 year.
  strSQL = "UPDATE tblOccurrence SET tblOccurrence.[Occurrence Dropped] = True"
  strSQL = strSQL & " WHERE [Date] <=DateAdd('yyyy',-1,Now())"
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True

'2. Check all records in the current year and starting with the earliest date
'   see if there is a span of more than 4 months

  Set recOccurrence = New ADODB.Recordset
  Set recEmployee = New ADODB.Recordset

  strSQL = "SELECT Distinct tblOccurrence.Employee FROM tblOccurrence"
  recEmployee.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recEmployee
    .MoveFirst
    Do While Not .BOF And Not .EOF
      Do
        ' open the active set for this employee
        strSQL = "SELECT OccurrenceID, Employee, [Date], [Occurrence Dropped], [Occurrence Reference] FROM tblOccurrence"
        strSQL = strSQL & " WHERE Employee='" & .Fields("Employee")
        strSQL = strSQL & "' AND [Occurrence Dropped]=False AND [Occurrence Reference]=False"
        ' Exclude ID's in this active set that we have already checked
        If strFilesChecked <> "" Then
          strSQL = strSQL & " AND OccurrenceID Not IN(" & Left(strFilesChecked, Len(strFilesChecked) - 1) & ")"
        End If
       
        strSQL = strSQL & " Order By Date Asc"
        recOccurrence.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        With recOccurrence
          ' .MoveFirst                ' <-- aw 15-apr-2004 moved this down 2 lines
          If Not .BOF And Not .EOF Then
            .MoveFirst                ' <-- aw 15-apr-2004 modified positon of this line
            lNextOldestID = .Fields("OccurrenceID")
            lRecordChecked = lNextOldestID
            dNextOldestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            .MoveNext
           
            If .EOF Then: Exit Do
            lNextNewestID = .Fields("OccurrenceID")
            dNextNewestDate = Format(.Fields("Date"), "dd-mmm-yyyy")
            'If a span of 4 months is found
            '  and there are no records within the current year marked [Occurrence Reference]
            '  then mark the oldest record in the current year as dropped
            '  and mark the record the 4 month span was found.
            If dNextOldestDate <= DateAdd("m", -4, dNextNewestDate) Then
              ' a span of 4 months has been found
              '  then mark the oldest record in the current year as dropped
              '  and mark the record the 4 month span was found.
              '  Of the two records we are comparing, which record gets marked as
              '  Fields("Occurrence Reference") = true ????
              '  dNextOldestDate or dNextNewestDate  ????
             
              '  ==========================================
              '  Code to mark the oldest occurence, in current year, not marked as dropped,
              '  for this employee goes here.
              '
              '  note: Get the ID of oldest record not dropped for this Employee
              '        Then run some sql here to mark as dropped and re-populate the variable
              '  ==========================================
              strFilesChecked = strFilesChecked & .Fields("OccurrenceID") & ","
              Dim lOldestOffenceID As Long
              lOldestOffenceID = getOldestActiveOffenceID(.Fields("Employee"))
              Call doMarkOldestActiveOffenceID(lOldestOffenceID)
              Call doMarkOccurencReference(lNextNewestID)
             
            Else
              ' Add the ID of this record to strFilesChecked(List of records to exclude on next loop)
              strFilesChecked = strFilesChecked & lRecordChecked & ","
            End If
         
          Else     '<-- aw 15-apr-2004 Added the Else to get out of the inner loop if .BOF and .EOF
            .Close
            Exit Do
         
          End If
          .Close
        End With
      Loop
      strFilesChecked = ""
      .MoveNext
    Loop
  End With
 
ExitProcedure:
  On Error Resume Next
  Set recOccurrence = Nothing
  Set recEmployee = Nothing
  Exit Sub

ReportError:
  Dim msg As String
  msg = "Error in " & Me.Name & "Command11_Click():" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
End Sub



Private Sub doMarkOccurencReference(lNextNewestID As Long)

  ' Note: aw 14-apr-2004
  ' Returns: nothing
  ' Called by: Form1_Command13_Click()
 
  On Error GoTo ExitProcedure
 
  Dim strSQL As String
  Dim strWhere As String
 
  strSQL = "UPDATE tblOccurrence SET [Occurrence Reference] = True"
  strSQL = strSQL & "  WHERE OccurrenceID =" & lNextNewestID
 
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True
 
ExitProcedure:
  On Error Resume Next
  Exit Sub

ReportError:
  Dim msg As String
  msg = "Error in " & Me.Name & ".doMarkOccurencReference()" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
 
End Sub




Private Sub doMarkOldestActiveOffenceID(lOldestOffenceID As Long)

  ' Note: aw 14-apr-2004
  ' Returns: nothing
  ' Called by: Form1_Command13_Click()
 
  On Error GoTo ExitProcedure
 
  Dim strSQL As String
  Dim strWhere As String
 
  strSQL = "UPDATE tblOccurrence SET [Occurrence Dropped] = True"
  strSQL = strSQL & "  WHERE OccurrenceID =" & lOldestOffenceID
 
  DoCmd.SetWarnings False
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True
 
ExitProcedure:
  On Error Resume Next
  Exit Sub

ReportError:
  Dim msg As String
  msg = "Error in " & Me.Name & ".doMarkOldestActiveOffenceID()" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
 
End Sub


Private Function getOldestActiveOffenceID(empName As String) As Long

  On Error GoTo ExitProcedure
 
  Dim strSQL As String
  Dim strWhere As String
  Dim recOldestOffence As ADODB.Recordset
  Set recOldestOffence = New ADODB.Recordset
 
  ' Note: aw 14-apr-2004
  '       In the test data OccurenceID's were not consistent with field("Date")
  '       when an orderby clause was applied
  '       Also dont need to filter on WHERE [Date] <=DateAdd('yyyy',-1,Now())
  '       Because update of records matching this descript runs prior to this function
 
 
  strSQL = "SELECT OccurrenceID, Date FROM tblOccurrence"
  strSQL = strSQL & " WHERE Employee='" & empName
  strSQL = strSQL & "' AND [Occurrence Dropped]=False ORDER BY [Date]"
 
  recOldestOffence.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recOldestOffence
    If Not .BOF And Not .EOF Then
      .MoveFirst
      getOldestActiveOffenceID = .Fields("OccurrenceID").Value
      .Close
    End If
  End With
 
 
ExitProcedure:
  On Error Resume Next
  Set recOldestOffence = Nothing
  Exit Function

ReportError:
  Dim msg As String
  msg = "Error in " & Me.Name & ".getOldestActiveOffenceID()" _
    & vbCr & "Error number " & CStr(Err.Number) _
    & " was generated by " & Err.Source _
    & vbCr & Err.Description
  MsgBox msg, vbExclamation + vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
  Resume ExitProcedure
 

 
End Function


10      Thayer, Trygve      1/2/1998      1      Call In            TRUE      FALSE
11      Thayer, Trygve      1/2/1999      1      Call In            TRUE      FALSE
12      Thayer, Trygve      1/2/2000      2      Call In            TRUE      FALSE
6      Thayer, Trygve      1/1/2001      2      Call In      tttt      TRUE      FALSE
7      Thayer, Trygve      1/1/2001      2      Call In      eeee      TRUE      FALSE
13      Thayer, Trygve      1/2/2001      1      Call In            TRUE      FALSE
8      Thayer, Trygve      1/1/2002      1      Call In      wwww      TRUE      FALSE
14      Thayer, Trygve      1/2/2002      1      Call In            TRUE      FALSE
5      Thayer, Trygve      3/30/2002      2      Call In            TRUE      FALSE
9      Thayer, Trygve      1/1/2003      1      Call In      rrrr      TRUE      FALSE
15      Thayer, Trygve      2/1/2003      1      Call In            TRUE      FALSE
16      Thayer, Trygve      3/1/2003      1      Call In            TRUE      FALSE
17      Thayer, Trygve      4/1/2003      1      Call In            TRUE      FALSE
1      Thayer, Trygve      4/10/2003      2      Call In      yep he      TRUE      FALSE
25      Thayer, Trygve      4/15/2003      1      Call In            TRUE      FALSE
18      Thayer, Trygve      5/15/2003      2      Call In            TRUE      FALSE
19      Thayer, Trygve      8/11/2003      1      Call In            FALSE      FALSE
23      Thayer, Trygve      12/11/20032      Call In            FALSE      TRUE
27      Thayer, Trygve      4/12/2004      1      Call In            FALSE      TRUE
29      Ausmus, Adam      4/14/2004      1      Call In            FALSE      FALSE
Alan WarrenApplications Developer

Commented:
Ok got it mate.



' from here:

  Set recOccurrence = New ADODB.Recordset
  Set recEmployee = New ADODB.Recordset

  strSQL = "SELECT Distinct tblOccurrence.Employee FROM tblOccurrence"
  recEmployee.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  With recEmployee
    .MoveFirst
    Do While Not .BOF And Not .EOF
     '=====================   ' add this if block here
     If recOccurrence.State <> 0 Then
        recOccurrence.Close
      End If
      '=====================
      Do

Alan
Trygve ThayerIT Director

Author

Commented:
Got It.   It did not mark anything but that is what I expected.    What was happening?

p.s. sent you a zip file before I saw your post.
Alan WarrenApplications Developer

Commented:

The recOccurence recordset was still open and I was trying to open it again after moving to next employee.
One of the gotcha's of using Exit Do

Alan
Trygve ThayerIT Director

Author

Commented:
Thanks,

I will continue on with development.  I did get a boomerang today but think I have a solution.  HR manager said it was possible to record an occurrence that was excused in which the value would be 0 or not count.  If when that happens I think the one entering the record should mark [Occurrence Dropped] manually and then all should work.  I think.....  Have not tested that yet.    Still recovering from the all nighter.    When the supervisor called me and said he saw the server smoking he was not joking.
Alan WarrenApplications Developer

Commented:
What was it smoking? LOL
Trygve ThayerIT Director

Author

Commented:
The Cleaning people decided the computer room needed mopping.  Not to good when you sling water into computers.
Trygve ThayerIT Director

Author

Commented:
alanwarren.......the HR guy did it again !!!!

https://www.experts-exchange.com/Databases/MS_Access/Q_20956032.html
Unlock the solution to this question.
Thanks for using Experts Exchange.

Please provide your email to receive a sample view!

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.