带有/ Caps Lock 和 Shift 键的 VBA / API 键盘事件答案

【问题标题】：VBA / API Keyboard Events w/ Caps Lock & Shift Key带有/ Caps Lock 和 Shift 键的 VBA / API 键盘事件
【发布时间】：2013-08-12 21:33:47
【问题描述】：

目标：制作一个跟踪用户击键并在单元格(1,1)中显示的程序。

问题：已解决

代码：请参阅下面的工作副本。

代码包括按键：换档键，大写锁定，空格键，退格 & 退出键

【问题讨论】：

我删除了我的答案，因为它不正确。再看一遍，GetAsyncKeyState 好像没什么用。
关于您的测试用例的一个有趣点：如果您在宏运行时切换 CAPS LOCK 两次（如您所描述）然后退出宏，CAPS LOCK 键关闭，但键盘输入大写，好像 CAPS LOCK 会打开！
你看过this SO question 吗？我认为主要区别在于偷看消息后，他们将其发布回应用程序
我从链接中的代码开始，我搞砸它的产物，就是你在上面看到的。我将回到绘图板上，看看我缺少什么。顺便感谢您的帮助。

标签： api vba keyboard-events shift capslock

【解决方案1】：

一个工作示例：

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

【讨论】：