Dim KeyDel As dao.Recordset, Dbscurrent As dao.Database
Dim LessDays As Date
Dim DelCount As Variant
Dim DelCount1 As Variant
Dim BlankCount As Variant
Dim BlankCount1 As Variant
Dim Blankttl As Variant
Dim DelSum As Variant
Dim DelSum1 As Variant
Dim Delttl As Variant
Dim Delttl1 As Variant
'If it errors out end the code and contact IT department
On Error GoTo ErrorBox
' Opens Alert Box and lock menu buttons
DoCmd.OpenForm "AlertMsg"
DoCmd.RepaintObject
Me.Command0.Enabled = False
Me.Command1.Enabled = False
Me.Command4.Enabled = False
DoCmd.SetWarnings False
'Set Recordset
Set Dbscurrent = CurrentDb()
Set KeyDel = Dbscurrent.OpenRecordset("Keyencetbl")
Set KeyDel1 = Dbscurrent.OpenRecordset("Keyencetbl1")
' Counting Current Records/Counting all blank records
DelCount = DCount("*", "Keyencetbl")
DelCount1 = DCount("*", "Keyencetbl1")
BlankCount = DCount("*", "Keyencetbl", "IsNull([RawData] And [Recorded On])")
BlankCount1 = DCount("*", "Keyencetbl1", "IsNull([RawData] And [Recorded On])")
' Will leave 7 days of data in record
LessDays = Date - 6
'Will delete empty records
DoCmd.OpenQuery "KeyNullDelete"
DoCmd.OpenQuery "KeyNullDelete1"
' [Keyencetbl]
' Moving through record and deleting if the current record is less than
' the hishest ID on the server and less than 7 days prior to today
' The Keytbl1 is a subform located on the Menu form. It is attached to
' a stored procedure.
If KeyDel.RecordCount <> 0 Then
KeyDel.MoveFirst
Do Until KeyDel.EOF
If KeyDel!ID < Me.Keytbl1 And KeyDel![Recorded On] < LessDays Then
KeyDel.Delete
End If
KeyDel.MoveNext
Loop
End If
Set Dbscurrent = Nothing
Set KeyDel = Nothing
' [Keyencetbl1]
' Moving through record and deleting if the current record is less than
' the hishest ID on the server and less than 7 days prior to today
' The Keytbl2 is a subform located on the Menu form. It is attached to
' a stored procedure.
If KeyDel1.RecordCount <> 0 Then
KeyDel1.MoveFirst
Do Until KeyDel1.EOF
If KeyDel1!ID < Me.Keytbl2 And KeyDel1![Recorded On] < LessDays Then
KeyDel1.Delete
End If
KeyDel1.MoveNext
Loop
End If
Set Dbscurrent = Nothing
Set KeyDel1 = Nothing
DoCmd.SetWarnings True
' Count Records after delete and Calculating
DelSum = DCount("*", "Keyencetbl")
DelSum1 = DCount("*", "Keyencetbl1")
Delttl = DelCount + DelCount1 - DelSum - DelSum1
Blankttl = BlankCount + BlankCount1
' Set KeyStats Recordset
Dim rs1 As dao.Recordset, Dbscurrent1 As dao.Database
Set Dbscurrent1 = CurrentDb()
Set rs1 = Dbscurrent1.OpenRecordset("KeyStats")
' Open up KeyStats and enter in the amount deleted, Machine and Time and Date
If Delttl <> 0 Or Blankttl <> 0 Then
rs1.AddNew
rs1.Fields("RecDeleted") = Delttl
rs1.Fields("Machine") = "Key7601"
rs1.Fields("RecordedOn") = Now()
rs1.Fields("BlankRowsDeleted") = Blankttl
rs1.Update
rs1.Close
Dbscurrent1.Close
Set rs1 = Nothing
Set Dbscurrent1 = Nothing
End If
' Close Alert Box and unlocked menu buttons
DoCmd.Close acForm, "AlertMsg", acSaveNo
Me.Command0.Enabled = True
Me.Command1.Enabled = True
Me.Command4.Enabled = True
ExitHandler:
DoCmd.Close acForm, "AlertMsg", acSaveNo
DoCmd.OpenForm "Menu"
Me.Command0.Enabled = True
Me.Command1.Enabled = True
Me.Command4.Enabled = True
Exit Sub
ErrorBox:
Select Case Err
Case Is > 0
MsgBox "[Error #100] Network Connection Failed! Please contact IT Department. Hit 'OK' and report [Error #100] to continue", vbExclamation, ""
Resume ExitHandler
Case Else
MsgBox Err.Description, vbExclamation, "Error #: " & Err.Number
Resume ExitHandler
End Select
End Sub
