События клавиатуры VBA/API с клавишей Caps Lock и Shift

Рабочий пример:

Option Explicit
Option Compare Text

Private Type POINTAPI
  x As Long
  Y As Long
End Type

Private Type MSG
  hwnd As Long
  Message As Long
  wParam As Long
  lParam As Long
  time As Long
  pt As POINTAPI
End Type

Private Type KeyboardBytes
  kbByte(0 To 255) As Byte
End Type

Dim KB_Array As KeyboardBytes 'WAS kbArray
Const VK_BACK    As Long = &H8 '= 8
Const VK_TAB As Long = &H9 '= 9
Const VK_RETURN As Long = &HD '= 13
Const VK_SHIFT   As Long = &H10 '= 16
Const VK_CAPITAL As Long = &H14 '=20
Const VK_ESC     As Long = &H1B '= 27
Const VK_SPACE As Long = &H20 '= 32
Const WM_KEYDOWN As Long = &H100 'for PeekMessage
Const PM_REMOVE  As Long = &H1 'for PeekMessage
Const KEY_MASK As Integer = &HFF80 ' decimal -128

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal nVirtKey As Integer) As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetKeyboardState Lib "user32" (KB_Array As KeyboardBytes) As Long
Private Declare Function SetKeyboardState Lib "user32" (KB_Array As KeyboardBytes) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
  (ByRef lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long


Sub woops()
Dim msgMessage As MSG, iKeyCode As Long, lXLhwnd As Long, aString As String
Dim aExit As Boolean, CapsLock_On As Boolean, ShiftKey_On As Boolean

AppActivate "Microsoft Excel"
Cells(1, 1) = ""
lXLhwnd = FindWindow("XLMAIN", Application.Caption)

GetKeyboardState KB_Array
CapsLock_On = IIf(KB_Array.kbByte(VK_CAPITAL) = 1, True, False)
Cells(2, 1) = CapsLock_On

Do
  WaitMessage
  If PeekMessage(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
    iKeyCode = msgMessage.wParam
    Run KeyPress(iKeyCode, KB_Array, aString, CapsLock_On, ShiftKey_On, aExit)
  End If
Loop Until aExit = True
Cells(1, 1) = ""

End Sub

Private Function KeyPress(ByVal KeyAscii As Integer, ByRef KB_Array As KeyboardBytes, _
  ByRef String1 As String, ByRef CapsLock_On As Boolean, _
  ByRef ShiftKey_On As Boolean, ByRef aExit As Boolean)
Dim aValue As Long

Select Case KeyAscii
  Case VK_BACK: If String1 <> "" Then String1 = Left(String1, Len(String1) - 1)
  Case VK_SHIFT:
  Case VK_CAPITAL:
    KB_Array.kbByte(VK_CAPITAL) = IIf(KB_Array.kbByte(VK_CAPITAL) = 1, 0, 1)
    SetKeyboardState KB_Array
    CapsLock_On = IIf(KB_Array.kbByte(VK_CAPITAL) = 1, True, False)
  Case VK_ESC: aExit = True
  Case VK_SPACE: String1 = String1 & " "
  Case 65 To 90: 'A to Z
    If CapsLock_On = False Then aValue = KeyAscii + 32 Else aValue = KeyAscii
    If GetAsyncKeyState(VK_SHIFT) And KEY_MASK < 0 Then ShiftKey_On = True Else ShiftKey_On = False
    If ShiftKey_On = True Then
      If CapsLock_On = True Then aValue = aValue + 32 Else aValue = aValue - 32
    End If
    String1 = String1 & Chr(aValue)

  Case Else: String1 = String1 & "[" & Chr(KeyAscii) & " - " & KeyAscii & "]"
End Select
Cells(1, 1) = String1
End Function