Option Compare Database
Option Explicit
'===== DETECT USER INPUT =====
'CODE FROM: https://www.tek-tips.com/viewthread.cfm?qid=1012106
'TWEAKED BY: Adelina 13/08/2021
'- Added option to detect if the main window has focus or not
'-->Property OnlyAccessApp: boolean (YES-detect input in access, NO-detect input overall)
'-->Property WindowId: Required if OnlyAccessApp=True. Passed at class initialisation from the detecting form, with the api GetForegroundWindow. Needs to be declared at form level also.
'- Added 64b declarations
'=============================
'@---------------------- API Functions -------------------------@
#If Win64 Then
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function GetForegroundWindow Lib "User32" () As LongPtr
Private Declare PtrSafe Function IsIconic Lib "User32" (ByVal hWnd As LongPtr) As Long
#Else
Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Private Declare Function GetForegroundWindow Lib "User32" () As Long
Private Declare Function IsIconic Lib "User32" (ByVal hWnd As Long) As Integer
#End If
'@------------------------- Events -----------------------------@
Public Event InputDetected(ByVal dtTimeOccurred As Date)
Public Event MaxIdleTimeDetected(ByVal dtTimeOccurred As Date)
'@------------------------ Variables ---------------------------@
Private mlngTimeOutMinutes As Long
Private mlngWindowId As Long
Private mblnOnlyAccessApp As Boolean
Private mblnPaused As Boolean
Private mblnShowSplash As Boolean
Private mdtStartTime As Date
Private mPosOld As POINTAPI
Private mPosNew As POINTAPI
'@-------------------------- Types -----------------------------@
Private Type POINTAPI
X As Long
Y As Long
End Type
'@----------------------- Constructor --------------------------@
Private Sub Class_Initialize()
TimeOutMinutes = 15 'default timeout
End Sub
'@----------------------- Properties ---------------------------@
Public Property Get TimeOutMinutes() As Long
TimeOutMinutes = mlngTimeOutMinutes
End Property
Public Property Let TimeOutMinutes(ByVal lngTimeOutMinutes As Long)
mlngTimeOutMinutes = lngTimeOutMinutes
End Property
Public Property Get StartTime() As Date
StartTime = mdtStartTime
End Property
Private Property Let StartTime(ByVal dtStartTime As Date)
mdtStartTime = dtStartTime
End Property
Public Property Get ElapsedSeconds() As Long
ElapsedSeconds = DateDiff("s", StartTime, Now)
End Property
Public Property Get ElapsedMinutes() As Long
ElapsedMinutes = DateDiff("s", StartTime, Now) \ 60
End Property
Public Property Get Paused() As Boolean
Paused = mblnPaused
End Property
Public Property Let Paused(ByVal blnPaused As Boolean)
mblnPaused = blnPaused
End Property
Public Property Get OnlyAccApp() As Boolean
OnlyAccApp = mblnOnlyAccessApp
End Property
Public Property Let OnlyAccApp(ByVal blnAccessApp As Boolean)
mblnOnlyAccessApp = blnAccessApp
End Property
Public Property Get WindowID() As Long
WindowID = mlngWindowId
End Property
Public Property Let WindowID(ByVal lngWindowID As Long)
mlngWindowId = lngWindowID
End Property
Public Property Get ShowSplash() As Boolean
ShowSplash = mblnShowSplash
End Property
Public Property Let ShowSplash(ByVal blnShowSplash As Boolean)
mblnShowSplash = blnShowSplash
End Property
'@---------------------- Public Methods ------------------------@
Public Sub CheckInput()
If Paused Then Exit Sub
If OnlyAccApp Then
If WindowID <> CLng(GetForegroundWindow) Then
'for popup forms the function will trigger since the ForegroundWindow is different from the main window
'so i show in the statusbar how much time it passed since opening that form
SysCmd acSysCmdSetStatus, ElapsedSeconds & " sec."
'if main window is minimised i show the splash screen if ShowSplash=True
If IsIconic(hWndAccessApp) = 1 Then
If ShowSplash Then If Not IsFormOpen("frmIDLE") Then DoCmd.OpenForm "frmIDLE", acNormal
End If
Call UpdateElapsedTime
Exit Sub
End If
End If
If ShowSplash Then If IsFormOpen("frmIDLE") Then DoCmd.Close acForm, "frmIDLE", acSaveNo
If Not CheckMouseMoved() Then
If Not CheckKeyboardUsed() Then
Call UpdateElapsedTime
Exit Sub
End If
End If
Call Reset
RaiseEvent InputDetected(Now)
End Sub
Public Sub StartCheckingIdleTime()
Call Reset
Paused = False
End Sub
Public Sub StopCheckingIdleTime()
Paused = True
End Sub
Public Sub Reset()
If GetCursorPos(mPosNew) <> 0 Then
mPosOld.X = mPosNew.X
mPosOld.Y = mPosNew.Y
End If
StartTime = Now
End Sub
'@--------------------- Private Methods ------------------------@
Private Sub UpdateElapsedTime()
If ElapsedMinutes >= TimeOutMinutes Then
RaiseEvent MaxIdleTimeDetected(Now)
End If
If ShowSplash Then
If IsFormOpen("frmIDLE") Then Forms!frmIDle!Sec = ElapsedSeconds & " sec."
End If
End Sub
Private Function CheckMouseMoved() As Boolean
If GetCursorPos(mPosNew) = 0 Then Exit Function
If ((mPosNew.X <> mPosOld.X) Or (mPosNew.Y <> mPosOld.Y)) Then
mPosOld.X = mPosNew.X
mPosOld.Y = mPosNew.Y
CheckMouseMoved = True
End If
End Function
Private Function CheckKeyboardUsed() As Boolean
Dim lngKey As Long
For lngKey = 0 To 255
If (GetAsyncKeyState(lngKey) And &H8001) <> 0 Then
CheckKeyboardUsed = True
End If
Next lngKey
End Function
Private Function IsFormOpen(frmName As String) As Boolean
IsFormOpen = False
If SysCmd(acSysCmdGetObjectState, acForm, frmName) <> 0 Then
If Forms(frmName).CurrentView <> 0 Then
IsFormOpen = True
End If
End If
End Function
'@----------------------- End of Class -------------------------@
P pun intended). I try to evoid that as much as possible (alway almost) since it opens a whole can of worms.
