RichBisset
asked on
Enforce a session timeout for users
I am building an application in VB6 and need to be able to detect if a user's session has been idle for 20 minutes.
I found a question on EE which dealt with something similar and TravisHall provided the following code:
=====Code to go in main form called frmEditor=======
'Declarations section
Private mhActivityEvent As Long
Private mhSignalLoopThread As Long
Private Sub Form_Load()
mhActivityEvent = CreateEvent(0, 0, 0, 0)
End Sub
Private Sub Form_Unload(Cancel As Integer)
If mhSignalLoopThread <> 0 Then CloseHandle mhSignalLoopThread
CloseHandle mhActivityEvent
End Sub
======Code from the mdiTimers module:===========
Public Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As Long) As Long
Public Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Any, ByRef lpParameter As Any, ByVal dwCreationFlags As Long, ByRef lpThreadId As Long) As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_TIMEOUT& = &H102&
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE _
Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE _
Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT _
Or QS_POSTMESSAGE _
Or QS_TIMER _
Or QS_PAINT _
Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE _
Or QS_PAINT _
Or QS_TIMER _
Or QS_POSTMESSAGE _
Or QS_MOUSEBUTTON _
Or QS_MOUSEMOVE _
Or QS_HOTKEY _
Or QS_KEY)
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Public Const WM_USER = &H400
Public Const WM_AUTOLOGOFF = WM_USER
Public Sub SignalLoop(ByRef hEvent As Long)
Dim lRet As Long
Do
lRet = MsgWaitForMultipleObjects(
Select Case lRet
Case WAIT_OBJECT_0
Case WAIT_OBJECT_0 + 1
DoEvents
Case WAIT_TIMEOUT
MsgBox ("timeout")
'SendMessage frmEditor.hwnd, WM_AUTOLOGOFF, 0, 0
Exit Do
End Select
Loop
End Sub
However, he suggests to subclass the frmEditor form in order to gain acces to the WM_AUTOLOGOFF message. I dont have any experience of subclassing forms and i have to admit a lot of the above code is alien to me.
if someone (ie TravisHall) could help me turn the above code into a working solution i would be very grateful!
Rich
ps. operating system is windows NT, 98 and 2000
I found a question on EE which dealt with something similar and TravisHall provided the following code:
=====Code to go in main form called frmEditor=======
'Declarations section
Private mhActivityEvent As Long
Private mhSignalLoopThread As Long
Private Sub Form_Load()
mhActivityEvent = CreateEvent(0, 0, 0, 0)
End Sub
Private Sub Form_Unload(Cancel As Integer)
If mhSignalLoopThread <> 0 Then CloseHandle mhSignalLoopThread
CloseHandle mhActivityEvent
End Sub
======Code from the mdiTimers module:===========
Public Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As Long) As Long
Public Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Any, ByRef lpParameter As Any, ByVal dwCreationFlags As Long, ByRef lpThreadId As Long) As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_TIMEOUT& = &H102&
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE _
Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE _
Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT _
Or QS_POSTMESSAGE _
Or QS_TIMER _
Or QS_PAINT _
Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE _
Or QS_PAINT _
Or QS_TIMER _
Or QS_POSTMESSAGE _
Or QS_MOUSEBUTTON _
Or QS_MOUSEMOVE _
Or QS_HOTKEY _
Or QS_KEY)
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Public Const WM_USER = &H400
Public Const WM_AUTOLOGOFF = WM_USER
Public Sub SignalLoop(ByRef hEvent As Long)
Dim lRet As Long
Do
lRet = MsgWaitForMultipleObjects(
Select Case lRet
Case WAIT_OBJECT_0
Case WAIT_OBJECT_0 + 1
DoEvents
Case WAIT_TIMEOUT
MsgBox ("timeout")
'SendMessage frmEditor.hwnd, WM_AUTOLOGOFF, 0, 0
Exit Do
End Select
Loop
End Sub
However, he suggests to subclass the frmEditor form in order to gain acces to the WM_AUTOLOGOFF message. I dont have any experience of subclassing forms and i have to admit a lot of the above code is alien to me.
if someone (ie TravisHall) could help me turn the above code into a working solution i would be very grateful!
Rich
ps. operating system is windows NT, 98 and 2000
ASKER
n_narayanan,
I ran the above code and it did not return a value for the y axis of the mouse pointer position.
I ran the above code and it did not return a value for the y axis of the mouse pointer position.
Hi
Keep the above code in a Module i.e. .bas file.
Check the code like this
In your form put a timer control,
In your timer control, set the time for 20 Minutes
In
Private Sub Timer1_Timer()
if not InputCheck then
'System is idle for 20 mins
'Place your code whatever you want.
end if
End Sub
Cheers
Narayanan
Keep the above code in a Module i.e. .bas file.
Check the code like this
In your form put a timer control,
In your timer control, set the time for 20 Minutes
In
Private Sub Timer1_Timer()
if not InputCheck then
'System is idle for 20 mins
'Place your code whatever you want.
end if
End Sub
Cheers
Narayanan
ASKER
The code is working well apart from two problems.
firstly, no value is returned for the y axis of the mouse pointer position - it is always equal to 0.
secondly, if i use the Exit For statement in this function:
For IntKeyValue = 8 To 126
InputCheck = CBool(GetAsyncKeyState(Asc
If InputCheck Then
Exit For
End If
Next
...and press more than one key during the test, it exits the loop after the first key that has been pressed, but when it runs the function next time around it registers that the other key(s) were pressed.
for instance if i run a test and type in A,B,C between a single timer interval, the code above will quit after the 'A' key has found to have changed.
then if i dont press a key during the next interval, it will think that i have pressed the 'B' key. Then next interval it thinks i have pressed the 'C' key.
if i remove the exit for statement it works perfectly.
firstly, no value is returned for the y axis of the mouse pointer position - it is always equal to 0.
secondly, if i use the Exit For statement in this function:
For IntKeyValue = 8 To 126
InputCheck = CBool(GetAsyncKeyState(Asc
If InputCheck Then
Exit For
End If
Next
...and press more than one key during the test, it exits the loop after the first key that has been pressed, but when it runs the function next time around it registers that the other key(s) were pressed.
for instance if i run a test and type in A,B,C between a single timer interval, the code above will quit after the 'A' key has found to have changed.
then if i dont press a key during the next interval, it will think that i have pressed the 'B' key. Then next interval it thinks i have pressed the 'C' key.
if i remove the exit for statement it works perfectly.
Thanks RichBisset, I have not noticed that earlier.
Narayanan
Narayanan
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
The solution is close enough!
Thanks for the help
Thanks for the help
ASKER
see last entry
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Private Type POINTAPI
x As Integer
Y As Integer
End Type
Private posOld As POINTAPI
Private posNew As POINTAPI
Public Function InputCheck() As Boolean
Dim i As Integer
'take mouse coordinates as they are
Call GetCursorPos(posNew)
'compare them with the old values
If ((posNew.x <> posOld.x) Or (posNew.Y <> posOld.Y)) Then
posOld = posNew
InputCheck = True
Exit Function ' mouse is moved so user is activ
End If
Dim IntKeyValue As Integer 'key value
For IntKeyValue = 8 To 126
InputCheck = CBool(GetAsyncKeyState(Asc
If InputCheck Then
Exit For
End If
Next
End Function
If this function returns true, system is not idle. If it returns false then it is idle.