I would like to detect monitor states.
To do that, I register the WM_POWERBROADCAST message.
The lParam of this message contains PBT_POWERSETTINGCHANGE.
typedef struct {
GUID PowerSetting;
DWORD DataLength;
UCHAR Data[1];
} POWERBROADCAST_SETTING, *PPOWERBROADCAST_SETTING;
GUID is defined like this in VB6:
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
How are
DWORD DataLength;
UCHAR Data[1];
to be translated to VB6?
The UCHAR Data[1] member of the POWERBROADCAST_SETTING structure indicates an array of bytes which depends on the PowerSetting and DataLength member. According to the docs, the Data member can be a GUID or a DWORD. So the simplest way in VB6 would be to declare a structure for the fixed members and get the remaining data in a second step according to the PowerSetting member.
Public Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PowerBroadcastSetting
PowerSetting As Guid
DataLength As Long
End Type
The window procedure should look like this:
Public Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim g As Guid
Dim L As Long
Dim pbs As PowerBroadcastSetting
Select Case iMsg
Case WM_POWERBROADCAST
Select Case wParam
Case PBT_APMPOWERSTATUSCHANGE
DebugPrint "PBT_APMPOWERSTATUSCHANGE"
Case PBT_APMRESUMEAUTOMATIC
DebugPrint "PBT_APMRESUMEAUTOMATIC"
Case PBT_APMRESUMESUSPEND
DebugPrint "PBT_APMRESUMESUSPEND"
Case PBT_APMSUSPEND
DebugPrint "PBT_APMSUSPEND"
Case PBT_POWERSETTINGCHANGE
CopyMemory pbs, ByVal lParam, Len(pbs)
DebugPrint "PBT_POWERSETTINGCHANGE " & GuidToString(pbs.PowerSetting)
Select Case GuidToString(pbs.PowerSetting)
Case GUID_POWERSCHEME_PERSONALITY
CopyMemory g, ByVal lParam + Len(pbs), 16
DebugPrint "New power scheme: " & GuidToString(g)
Case GUID_SESSION_DISPLAY_STATUS
CopyMemory L, ByVal lParam + Len(pbs), 4
DebugPrint "Display status: " & L
Case GUID_MONITOR_POWER_ON
CopyMemory L, ByVal lParam + Len(pbs), 4
DebugPrint "Primary Monitor state: " & L
Case GUID_CONSOLE_DISPLAY_STATE
CopyMemory L, ByVal lParam + Len(pbs), 4
DebugPrint "Console Display state: " & L
End Select
End Select
'An application should return TRUE if it processes this message.
WindowProc = 1
Exit Function
End Select
'Pass message to original window proc
WindowProc = CallWindowProc(ProcOld, hWnd, iMsg, wParam, lParam)
End Function
Following API declarations are used:
Public Const GWL_WNDPROC As Long = (-4)
Private Const WM_POWERBROADCAST As Long = 536
Public Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PowerBroadcastSetting
PowerSetting As Guid
DataLength As Long
End Type
'Power status has changed.
Private Const PBT_APMPOWERSTATUSCHANGE = 10
'Operation is resuming automatically from a low-power state. This message is sent every time the system resumes.
Private Const PBT_APMRESUMEAUTOMATIC As Long = 18
'Operation is resuming from a low-power state. This message is sent after PBT_APMRESUMEAUTOMATIC if the resume is triggered by user input, such as pressing a key.
Private Const PBT_APMRESUMESUSPEND As Long = 7
'System is suspending operation.
Private Const PBT_APMSUSPEND As Long = 4
'A power setting change event has been received.
Private Const PBT_POWERSETTINGCHANGE As Long = 32787
'Power Setting GUIDs
'The active power scheme personality has changed. All power schemes map to one of these personalities.
'The Data member is a GUID that indicates the new active power scheme personality.
Public Const GUID_POWERSCHEME_PERSONALITY As String = "{245D8541-3943-4422-B025-13A784F679B7}"
'The display associated with the application's session has been powered on or off.
'The Data member is a DWORD with one of the following values.
'0x0 - The display is off.
'0x1 - The display is on.
'0x2 - The display is dimmed.
Public Const GUID_SESSION_DISPLAY_STATUS As String = "{2B84C20E-AD23-4DDF-93DB-05FFBD7EFCA5}"
Public Const GUID_MONITOR_POWER_ON As String = "{02731015-4510-4526-99E6-E5A17EBD1AEA}"
' Windows 8 +
Public Const GUID_CONSOLE_DISPLAY_STATE As String = "{6FE69556-704A-47A0-8F24-C28D936FDA47}"
'Notifications are sent using WM_POWERBROADCAST messages with a wParam parameter of PBT_POWERSETTINGCHANGE.
Public Const DEVICE_NOTIFY_WINDOW_HANDLE As Long = 0
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)
Public Declare Function RegisterPowerSettingNotification Lib "user32.dll" (ByVal hRecipient As Long, PowerSettingGuid As Guid, ByVal Flags As Long) As Long
Public Declare Function UnregisterPowerSettingNotification Lib "user32.dll" (ByVal Handle As Long) As Long
Private Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Guid, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, pclsid As Guid) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
And the helper functions:
Public Function GuidToString(g As Guid) As String
Dim L As Long
Dim b(0 To 77) As Byte
'we have space for 38 unicode chars (guid incl. brackets) + terminating zero (78 bytes)
L = StringFromGUID2(g, VarPtr(b(0)), 39)
'strip terminating 0, convert to string
GuidToString = Left(b, L - 1)
End Function
Public Function GuidFromString(ByVal gs As String) As Guid
CLSIDFromString StrPtr(gs), GuidFromString
End Function
Public Sub DebugPrint(ByVal s As String)
OutputDebugString s & vbCrLf
End Sub
Test Form in VB6:
Option Explicit
Private isSubclassed As Boolean
Private hScheme As Long
Private hDisplay As Long
Private hMonitor As Long
Private hConsole As Long
Private Sub cmdRegister_Click()
Unregister
Register
End Sub
Private Sub cmdUnregister_Click()
Unregister
End Sub
Private Sub Register()
ProcOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
isSubclassed = True
MsgBox "Subclassed"
'Register Power Events
hScheme = RegisterPowerSettingNotification(hWnd, GuidFromString(GUID_POWERSCHEME_PERSONALITY), DEVICE_NOTIFY_WINDOW_HANDLE)
hDisplay = RegisterPowerSettingNotification(hWnd, GuidFromString(GUID_SESSION_DISPLAY_STATUS), DEVICE_NOTIFY_WINDOW_HANDLE)
hConsole = RegisterPowerSettingNotification(hWnd, GuidFromString(GUID_CONSOLE_DISPLAY_STATE), DEVICE_NOTIFY_WINDOW_HANDLE)
MsgBox "Registered " & hScheme & " " & hDisplay & " " & hMonitor & " " & hConsole
End Sub
Private Sub Unregister()
'Unregister Power Events
If hScheme Then
UnregisterPowerSettingNotification hScheme
hScheme = 0
End If
If hDisplay Then
UnregisterPowerSettingNotification hDisplay
hDisplay = 0
End If
If hMonitor Then
UnregisterPowerSettingNotification hMonitor
hMonitor = 0
End If
If hConsole Then
UnregisterPowerSettingNotification hConsole
hConsole = 0
End If
'Unsubclass
If isSubclassed Then
SetWindowLong hWnd, GWL_WNDPROC, ProcOld
isSubclassed = False
MsgBox "Unsubclassed"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unregister
End Sub
Edit:
Added GUID_CONSOLE_DISPLAY_STATE.
Here are the outputs caught with DebugView on Windows 10:
Displays put in standby by the power management of Windows after inactivity:
[7752] PBT_POWERSETTINGCHANGE {6FE69556-704A-47A0-8F24-C28D936FDA47}
[7752] Console Display state: 2
[7752] PBT_POWERSETTINGCHANGE {2B84C20E-AD23-4DDF-93DB-05FFBD7EFCA5}
[7752] Display status: 2
After 15 Seconds:
[7752] PBT_POWERSETTINGCHANGE {6FE69556-704A-47A0-8F24-C28D936FDA47}
[7752] Console Display state: 0
[7752] PBT_POWERSETTINGCHANGE {02731015-4510-4526-99E6-E5A17EBD1AEA}
[7752] Primary Monitor state: 0
[7752] PBT_POWERSETTINGCHANGE {2B84C20E-AD23-4DDF-93DB-05FFBD7EFCA5}
[7752] Display status: 0
WakeUp:
[7752] PBT_POWERSETTINGCHANGE {6FE69556-704A-47A0-8F24-C28D936FDA47}
[7752] Console Display state: 1
[7752] PBT_POWERSETTINGCHANGE {02731015-4510-4526-99E6-E5A17EBD1AEA}
[7752] Primary Monitor state: 1
[7752] PBT_POWERSETTINGCHANGE {2B84C20E-AD23-4DDF-93DB-05FFBD7EFCA5}
[7752] Display status: 1
If you switch off the displays manually, there will be no notifications, at least with my hardware. Not sure, if on other systems the events will be raised.
Related
I've searched, and can't seem to find an answer, so any help would be appreciated.
I want to make a hotkey, but when the hotkey is pressed, I don't want the actual "character" to be displayed, just the action to be performed.
So for example, I have this:
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As KeyCodeConstants) As Long
Private Const VK_A = &H41
Private Sub keyboardTimer001_Timer()
If KeyDown(VK_A) Then
' do my stuff, but DONT DISPLAY the letter "A"
End If
end sub
So this basically just has a timer (interval 1) checking the async keyboard. If it detects that the letter "a" was pressed, I perform an action. But I want it to do this WITHOUT printing the letter "a".
How would I remove the key from the keyboard buffer/prevent it from displaying? (Side note - not sure if something like 'PeekMessage' would work - if so - does anyone know where I can find a good vb6 code sample where I can peek for stuff like 'ctrl+a' or 'ctrl+alt+a', etc, etc and then just clear the buffer, and perform my action?)
Thanks!
You can use a combination of RegisterHotKey and PeekMessage. The following code defines Key-A and Ctrl-A to perform actions:
Main Form
Option Explicit
Private Done As Boolean
Private Sub Form_Activate()
Done = False
RegisterHotKey Me.hWnd, &HBBBB&, MOD_NONE, vbKeyA
RegisterHotKey Me.hWnd, &HBBBA&, MOD_CONTROL, vbKeyA
ProcessMessages
End Sub
Private Sub ProcessMessages()
Dim Message As Msg
Do While Not Done
WaitMessage
If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
If Message.wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf Message.wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End If
DoEvents
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
Done = True
Call UnregisterHotKey(Me.hWnd, &HBBBB&)
Call UnregisterHotKey(Me.hWnd, &HBBBA&)
End Sub
The above code works well, but in a production app I might lean towards subclassing the main window. If you prefer subclassing, you will need to use a technique of your choosing and replace the ProcessMessages method with something like this:
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_HOTKEY
If wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End Select
End Function
As you can see, subclassing is a little cleaner. Of course, you need to define the Win API stuff. So in a module, place the following code:
Module
Option Explicit
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function WaitMessage Lib "user32" () As Long
Public Const MOD_NONE = &H0
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const MOD_WIN = &H8
Public Const PM_REMOVE = &H1
Public Const WM_HOTKEY = &H312
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type Msg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
On a Listview that doesn't have focus in Windows 10, Listview items are very faintly highlighted. I know that this is dependent on the system theme.
In this image, Item Number Three is selected.
Is there any way at all that this can be programmatically changed so that it is a darker shade of gray and more visible. Back in earlier versions of Windows, the standard theme showed this as darker gray.
Here is a solution to the problem that works well. It involves using subclassing and win api calls, so please proceed with caution.
This code uses a subclassing component provided by vbAccelerator, although you should be able to use any subclassing technique. In summary, the KillFocus message is overridden to achieve our goal.
Option Explicit
Implements ISubclass
Private Const LVS_SHOWSELALWAYS As Long = &H8
Private Const LVIS_FOCUSED As Long = &H1
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETNEXTITEM As Long = (LVM_FIRST + 12)
Private Const LVM_SETITEMSTATE As Long = (LVM_FIRST + 43)
Private Const LVNI_FOCUSED As Long = &H1
Private Const LVNI_SELECTED As Long = &H2
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Type LVITEM
Mask As Long
iItem As Long
iSubItem As Long
State As Long
StateMask As Long
pszText As String
cchTextMax As Long
iImage As Long
lParam As Long
iIndent As Long
iGroupId As Long
cColumns As Long
puColumns As Long
piColFmt As Long
iGroup As Long
End Type
Private Declare Function SendMessageW Lib "user32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Sub Form_Load()
ListView1.ListItems.Add , , "Item Number One"
ListView1.ListItems.Add , , "Item Number Two"
ListView1.ListItems.Add , , "Item Number Three"
ListView1.ListItems.Add , , "Item Number Four"
ListView1.ListItems.Add , , "Item Number Five"
ListView1.ListItems(3).Selected = True
AttachMessage Me, ListView1.hWnd, WM_KILLFOCUS
End Sub
Private Sub Form_Unload(Cancel As Integer)
DetachMessage Me, ListView1.hWnd, WM_KILLFOCUS
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
ISubclass_MsgResponse = emrConsume
End Property
Private Function ISubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim i As Long
Dim lvi As LVITEM
Select Case iMsg
Case WM_KILLFOCUS
'get selected item and remove focus
i = SendMessageW(hWnd, LVM_GETNEXTITEM, -1&, ByVal LVNI_FOCUSED Or LVNI_SELECTED)
If i <> -1 Then
lvi.StateMask = LVIS_FOCUSED
SendMessageW hWnd, LVM_SETITEMSTATE, i, lvi
End If
'return 1 to indicate we processed the message
ISubclass_WindowProc = 1
End Select
End Function
I want to store all active window title using EnumWindows API function. But I want to use the function which calls EnumWindows as an callback function too. I want to do this by changing the lParam variable so that the function knows when it has to call EnumWindows and when it is the callback function. The problem is that it gives me an error: "Expected Sub,Function or Propriety.". Here's my code:
Private Sub Command1_Click()
ReceiveHwnd 0, 1
End Sub
This part of code is in the module:
Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal Hwnd As Long) As Long
Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public HwndCount As Double, HwndArray() As Long
Public Function GetTitle(Hwnd As Long) As String
Dim Lenght As Long
Dim TempValue As String
Lenght = GetWindowTextLength(Hwnd) + 1
TempValue = Space$(Lenght)
GetWindowText Hwnd, TempValue, Lenght
GetTitle = Mid(TempValue, 1, Lenght - 1)
End Function
Public Function ReceiveHwnd(ByVal Hwnd As Long, ByVal lParam As Long) As Long
Static Count As Double
If lParam = 1 Then
EnumWindows AddressOf ReceiveHwnd, 0
Count = 0
Else
Count = Count + 1
ReDim Preserve HwndArray(1 To Count)
HwndArray(Count) = Hwnd
ReceiveHwnd = 1
End If
End Function
The error is at this line EnumWindows AddressOf ReceiveHwnd, 0 from ReceiveHwnd function.
Can you tell me where's the problem?
Is there a way to get the equivalent of VB's SelStart and SelLength properties from an Internet Explorer_Server object?
I've tried using SendMessage EM_GETSEL but it doesn't return anything.
You have to query the InternetExplorer_Server's HWND for its IHTMLDocument2 interface, and then you can use the browser's DOM interfaces to manipulate the browser content as needed:
How to get IHTMLDocument2 from a HWND
IHTMLDocument2::selection Property
Use this code where you want to calculate SelStart and SelLength. Replace InternetExplorer_Server.hWnd with a handle to your object.
Dim DomObj As IHTMLDocument2
Dim SelObj As IHTMLTxtRange
Set DomObj = IEDOMFromhWnd(InternetExplorer_Server.hWnd)
Set SelObj = DomObj.selection.createRange
TextToCheck$ = DomObj.body.innerText
' Calculate SelLength...
SelLength = Len(SelObj.Text)
SelObj.moveStart "character", -Len(TextToCheck$)
' Calculate SelStart...
SelStart = Len(SelObj.Text)
Requires the following code in a Module:
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
Public Function IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument2
Dim IID_IHTMLDocument2 As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hwnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument2
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes
hr = ObjectFromLresult(lRes, IID_IHTMLDocument2, 0, IEDOMFromhWnd)
End If
End Function
How can I lock an application after period of user inactivity?
I have a fat Windows applocation written in VB6. User must log into the application to use it. I need to log the user out after a period of inactivity. There are over 100 separate forms with one Main form that is always open after the user logs in, so I am looking for an application solution not a form level solution.
I am thinking about monitoring keyboard and mouse usage using WIN API.
Are you looking to measure inactivity in/of the application? Or the entire desktop?
If the latter, I’d suggest looking at GetLastInputInfo which you could call from time to time, either from another app, or from a timer in your main window. You can find a VB6 example of it's use here, though you can call it from just about any language you want as it is a Win32 API.
Here is the solution I decided upon. I wanted to document it properly. As this is the approach I had envisioned, it is not my code. Someone smarter than I did awhile ago.
I simply implemented the solution into my application.
Solution was posted by DaVBMan
Sample code
Original discussion thread.
The app is an multiple-document interface app.
In a common.bas module:
WIN API Code: for Keyboard and Mouse monitoring:
Private Const WH_KEYBOARD_LL = 13&
Private Const HC_ACTION = 0&
Private Const LLKHF_EXTENDED = &H1&
Private Const LLKHF_INJECTED = &H10&
Private Const LLKHF_ALTDOWN = &H20&
Private Const LLKHF_UP = &H80&
Private Const VK_RIGHT = &H27
Private Const VK_LEFT = &H25
Private Const VK_RSHIFT = &HA1
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
Flags As Long
time As Long
dwExtraInfo As Long
End Type
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cb As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private m_hDllKbdHook As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Global variables to hold DateTime last user activity and if mouse and keyboard activity has occurred
Public KeysHaveBeenPressed As Boolean
Public HasMouseMoved As Boolean
Public gLastUserActivity As Date
Code to detect keyboard activity
Public Function HookKeyboard() As Long
On Error GoTo ErrorHookKeyboard
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0&)
HookKeyboard = m_hDllKbdHook
Exit Function
ErrorHookKeyboard:
MsgBox Err & ":Error in call to HookKeyboard()." _
& vbCrLf & vbCrLf & "Error Description: " & Err.Description, vbCritical, "Warning"
Exit Function
End Function
Public Sub UnHookKeyboard()
On Error GoTo ErrorUnHookKeyboard
UnhookWindowsHookEx (m_hDllKbdHook)
Exit Sub
ErrorUnHookKeyboard:
MsgBox Err & ":Error in call to UnHookKeyboard()." _
& vbCrLf & vbCrLf & "Error Description: " & Err.Description, vbCritical, "Warning"
Exit Sub
End Sub
Public Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static kbdllhs As KBDLLHOOKSTRUCT
If nCode = HC_ACTION Then
'keys have been pressed
KeysHaveBeenPressed = True
End If
LowLevelKeyboardProc = CallNextHookEx(m_hDllKbdHook, nCode, wParam, lParam)
End Function
Code to detect mouse movement:
Public Sub CheckMouse()
On Error GoTo ErrCheckMouse
Dim p As POINTAPI
GetCursorPos p
If p.x <> LastMouse.x Or p.y <> LastMouse.y Then
HasMouseMoved = True
LastMouse.x = p.x
LastMouse.y = p.y
End If
Exit Sub
ErrCheckMouse:
MsgBox Err.Number & ": Error in CheckMouse(). Error Description: " & Err.Description, vbCritical, "Error"
Exit Sub
End Sub
On the Main parent Form:
Added a timer:
Private Sub muTimer_Timer()
CheckMouse
'Debug.Print "MU Timer Fire"
'Debug.Print "Keyboard:" & KeysHaveBeenPressed & " - " & "Mouse:" & HasMouseMoved
If HasMouseMoved = False And KeysHaveBeenPressed = False Then
If DateDiff("m", gLastUserActivity, Now) > gnMUTimeOut Then
muTimer.Interval = 0
<Make call to lock the application>
Else
'Debug.Print " dT "; DateDiff("s", gLastUserActivity, Now)
End If
Else
HasMouseMoved = False
KeysHaveBeenPressed = False
gLastUserActivity = Now
End If
'Debug.Print " dT "; DateDiff("s", gLastUserActivity, Now)
End Sub
Also on the MainForm load event:
Private Sub MDIForm_Load()
HookKeyboard
end sub
Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
UnHookKeyboard
end sub