Option Compare Database
Option Explicit
' Usage
'
' Import the form frmInactiveShutDown into your application and open it hidden at application startup.
'
' Set the inactivity period by adjusting values in the form OnOpen event procedure.
'
' Optionally include the basISDOptionalModule to take advantage of a global variable that is set
' to True when an Inactive Timeout occurs.
'
'* Set this constant to True if you want the ISD form to pop up in front of other
'* application windows when an Inactive Timeout occurs.
Const conPopUpISDFormForeground = True
Const conSeconndsPerMinute = 60
Dim sngStartTime As Single
Dim ctlSave As Control
Dim intMinutesUntilShutDown As Integer
Dim intMinutesWarningAppears As Integer
Private Const SW_RESTORE = 9
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
'v3.0 - Access 2010 64-bit compatibility
#If VBA7 Then
Private Declare PtrSafe Function SetForegroundWindow& Lib "user32" (ByVal hWnd As LongPtr)
Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
Private Declare Function SetForegroundWindow& Lib "user32" (ByVal hwnd As Long)
Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Private Function xg_CallIfPresent(pstrFunctionNameAndParms As String) As Integer
'* Call a function using the Eval function.
'* This method allows us to call a function whether it exists or not.
'*
'* Returns
'* 1 - Function found, executed, and returns True
'* 2 - Function found, executed, and returns False
'* 3 - Function not found
'* 99 - Other error
Dim intRtn As Integer
On Error Resume Next
If Eval(pstrFunctionNameAndParms) Then
If Err <> 0 Then
Select Case Err
Case 2425, 2426
intRtn = 3 '* The function is not found
Case Else
MsgBox "Error in xg_CallIfPresent when calling '" & pstrFunctionNameAndParms & "': " & Err.Number & " - " & Err.Description
intRtn = 99 '* Other error
End Select
Err.Clear
Else
intRtn = 1 '* Function evaluates to True
End If
Else
intRtn = 2 '* Function evaluates to False
End If
Exit_Section:
On Error Resume Next
xg_CallIfPresent = intRtn
On Error GoTo 0
Exit Function
Err_Section:
Beep
MsgBox "Error in xg_CallIfPresent: " & Err.Number & " - " & Err.Description
Err.Clear
Resume Exit_Section
End Function
Private Sub Form_Load()
Dim db As DAO.Database
Dim prp As DAO.Property
Dim Lrs As DAO.Recordset
Dim LSQL As String
'Open connection to current Access database
Set db = CurrentDb()
'Create SQL statement to retrieve value from GST table
LSQL = "select personeelsnummer from Tbl_users where User = true"
Set Lrs = db.OpenRecordset(LSQL)
'Retrieve value if data is found
If Lrs.EOF = False Then
Me.ComboPersoneelsnummer.Value = Lrs("personeelsnummer")
End If
Lrs.Close
Set Lrs = Nothing
'Open connection to current Access database
Set db = CurrentDb()
'Create SQL statement to retrieve value from GST table
LSQL = "select access_level from Tbl_users where User = true"
Set Lrs = db.OpenRecordset(LSQL)
'Retrieve value if data is found
If Lrs.EOF = False Then
Me.ComboAccesslevel.Value = Lrs("access_level")
End If
Lrs.Close
Set Lrs = Nothing
End Sub
Private Sub Form_Close()
On Error Resume Next
ctlSave = Nothing
Err.Clear
On Error GoTo 0
End Sub
Private Sub Form_Open(Cancel As Integer)
'* Set this variable to the number of minutes of inactivity
'* allowed before the application automatically shuts down.
intMinutesUntilShutDown = 60
'intMinutesUntilShutDown = 120
'* Set this variable to the number of minutes that the
'* warning form will appear before the application
'* automatically shuts down.
intMinutesWarningAppears = 2
'intMinutesWarningAppears = 2
Me.Visible = False
sngStartTime = Timer
End Sub
Private Sub Form_Timer()
'**********************************************************************
'* This timer event procedure will shut down the application
'* after a specified number of minutes of inactivity. Inactivity
'* is measured based on how long a control remains the ActiveControl.
'**********************************************************************
Dim sngElapsedTime As Single
Dim ctlNew As Control
Dim i As Integer
Dim FN(20) As String
On Error Resume Next
'If Time() > #5:00:00 PM# Then '* Uncomment this to have ISD start at a particular time of day
Set ctlNew = Screen.ActiveControl
If Err <> 0 Then
'* No activecontrol
'pddxxx need to use datediff("s" ... here because timer resets at midnight
' find difference in seconds
sngElapsedTime = Timer - sngStartTime
Err.Clear
Else
If ctlNew.Name = "InactiveShutDownCancel" Then
'* The warning form has appeared, and the cancel button
'* is the active control
sngElapsedTime = Timer - sngStartTime
Else
If ctlNew.Name = ctlSave.Name Then
'* Still at same control
sngElapsedTime = Timer - sngStartTime
Else
'* Some change has occured, we're at a new control
Set ctlSave = ctlNew
sngStartTime = Timer
End If
If Err <> 0 Then
Set ctlSave = Screen.ActiveControl
End If
End If
End If
Err.Clear
'Else
' sngElapsedTime = 0
'End If
Set ctlNew = Nothing
Select Case sngElapsedTime
Case Is > (intMinutesUntilShutDown * conSeconndsPerMinute)
'* Set global timeout variable, then shut down each form
'* This code can be used if there is code in the form's BeforeUpdate,
'* or OnClose event procedure that requires user input.
'* The variable "gintInactiveTimeout" can be checked in the form events
'* and can be used to prevent the user prompt code from executing.
Dim frm As Form
'* Set the global variable "gintInactiveTimeout" to True if the basISDOptionalModule is included
Select Case xg_CallIfPresent("isd_SetInactiveTimeoutVar(True)")
Case 1, 2, 3, 99
'* We'll accept the results regardless of the return code
Case Else
End Select
'* Close all forms
For i = 0 To 20
FN(i) = ""
Next i
i = 0
'* Find all open form names
For Each frm In Forms
If i > 20 Then
Exit For
End If
If frm.Name = "frmInactiveShutDown" Then
Else
FN(i) = frm.Name
i = i + 1
End If
Next frm
'* Now close them all
For i = 0 To 20
If FN(i) = "" Then
Else
'MsgBox "Closing " & FN(i)
DoCmd.Close acForm, FN(i), acSaveYes
End If
Next i
'* Set the global variable "gintInactiveTimeout" to False if the basISDOptionalModule is included
Select Case xg_CallIfPresent("isd_SetInactiveTimeoutVar(False)")
Case 1, 2, 3, 99
'* We'll accept the results regardless of the return code
Case Else
End Select
Set frm = Nothing
Set ctlSave = Nothing
DoCmd.RunSQL ("INSERT INTO Tbl_Aanmelden ( ID_Medewerker, Datum_tijd, Status_aanmelding ) " & vbCrLf & _
"SELECT DISTINCTROW fInitialenshutdown() AS Expr2, Now() AS Expr1, ""automatisch afgemeld na inactiviteit"" AS Expr3;")
DoCmd.RunSQL ("update Tbl_users set User = false where personeelsnummer = " & Me.ComboPersoneelsnummer.Value & "")
DoCmd.RunSQL ("update Tbl_users set sessie = null where personeelsnummer = " & Me.ComboPersoneelsnummer.Value & "")
Call AccessCloseButtonEnabled(True)
DoCmd.Quit (acQuitSaveAll)
Case Is > ((intMinutesUntilShutDown - intMinutesWarningAppears) * conSeconndsPerMinute)
'* Make the warning form visible if it is not already visible.
If Me.Visible Then
Else
Me.Visible = True
If conPopUpISDFormForeground Then
'* Un-minimize Access application if it is minimized
If IsIconic(Application.hWndAccessApp) Then
ShowWindow Application.hWndAccessApp, SW_RESTORE
End If
'* Make it the foreground window - open it in front of other application windows.
SetForegroundWindow (Me.hwnd)
End If
'* Open it on top of other modal windows.
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
End If
Case Else
'* The next line can be commented out if the form is opened hidden
'Me.Visible = False
End Select
Exit_Section:
On Error Resume Next
On Error GoTo 0
End Sub
Private Sub InactiveShutDownCancel_Click()
sngStartTime = Timer
Me.Visible = False
End Sub
