Option Explicit
Private Type KeyboardBytes
kbByte(0 To 255) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal uIDEvent As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As KeyboardBytes) As Long
Private Declare PtrSafe Function SetKeyboardState Lib "user32" (lppbKeyState As KeyboardBytes) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal uIDEvent As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As KeyboardBytes) As Long
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As KeyboardBytes) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
Private bEnable As Boolean
Public Property Let MonitorCapsLock(Optional ByVal EnableCapsLockInCurrentProcess As Boolean, ByVal bMonitor As Boolean)
Const VK_CAPITAL = &H14
Static lInitCapsState As Long
Dim kbArray As KeyboardBytes
bEnable = EnableCapsLockInCurrentProcess
If bMonitor Then
Call GetKeyboardState(kbArray)
lInitCapsState = kbArray.kbByte(VK_CAPITAL)
Call SetTimer(Application.hwnd, 0, 0, AddressOf TimerProc)
Else
Call KillTimer(Application.hwnd, 0)
Call GetKeyboardState(kbArray)
If lInitCapsState <> kbArray.kbByte(VK_CAPITAL) Then
Call ToggleCapsLock
End If
End If
End Property
Private Sub TimerProc()
Const VK_CAPITAL = &H14
Dim kbArray As KeyboardBytes
Dim lPID As Long, lCapsLockState As Long
lCapsLockState = IIf(bEnable, 0, 1)
Call GetKeyboardState(kbArray)
Call GetWindowThreadProcessId(GetForegroundWindow, lPID)
If lPID = GetCurrentProcessId Then
If kbArray.kbByte(VK_CAPITAL) = lCapsLockState Then
Call ToggleCapsLock
End If
Else
If kbArray.kbByte(VK_CAPITAL) <> lCapsLockState Then
kbArray.kbByte(VK_CAPITAL) = lCapsLockState
Call SetKeyboardState(kbArray)
Call ToggleCapsLock
End If
End If
End Sub
Private Sub ToggleCapsLock()
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Call keybd_event(VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0)
Call keybd_event(VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
End Sub