问题
I've built a simple VBA module to set a keyboard hook and a corresponding procedure to detect a pre-defined key combination (ctrl+3). It works perfectly except that when a user tries types in a window of the hosting app (PowerPoint), the code runs into an infinite loop causing the app to hang/crash. Here is the complete module with reproduction instructions:
' ===========================================================================
' Module : MOD_Keyboard_Shortcuts
' Purpose : Create pre-defined keyboard shortcuts for PowerPoint.
' Date : 14JUN2019
' Author : Jamie Garroch
' Company : BrightCarbon https://brightcarbon.com/
' Copyright (C) 2019 BrightCarbon Ltd. All Rights Reserved.
' ---------------------------------------------------------------------------
' How to test:
' 1. Run the SetHook procedure
' 2. Press keys in PowerPoint and confirm debug output
' 3. Run UnHook when finished testing
' ---------------------------------------------------------------------------
' To reproduce PowerPoint hang condition:
' 1. Run the SetHook procedure
' 2. In PowerPoint, click the Design tab
' 3. Click the dropdown in the Variants group
' 4. Select Colors / Customize Colors...
' 5. Place the cursor in the Name field and prerss any key to trigger hang
' 6. Note the infinite debug ouptut, even if a breakpoint is added on the
' first Debug.Print line in the KeyHandler procedure.
' 7. Kill the PowerPoint task using Windows Task Manager
' ===========================================================================
Option Explicit
' ===========================================================================
' Windows API and variable declarations
' ===========================================================================
#If VBA7 Then
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpFn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal nCode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private hWndPPT As LongPtr
Private hHook As LongPtr
#Else
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
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 CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private hWndPPT As Long
Private hHook As Long
#End If
Private bIsHooked As Boolean
' SetWindowsHook() codes
Private Const WH_MIN = (-1)
Private Const WH_MSGFILTER = (-1)
Private Const WH_JOURNALRECORD = 0
Private Const WH_JOURNALPLAYBACK = 1
Private Const WH_KEYBOARD = 2
Private Const WH_GETMESSAGE = 3
Private Const WH_CALLWNDPROC = 4
Private Const WH_CBT = 5
Private Const WH_SYSMSGFILTER = 6
Private Const WH_MOUSE = 7
Private Const WH_HARDWARE = 8
Private Const WH_DEBUG = 9
Private Const WH_SHELL = 10
Private Const WH_FOREGROUNDIDLE = 11
Private Const WH_MAX = 11
Private Const WH_KEYBOARD_LL = 13
' Hook Codes
Const HC_ACTION = 0
Const HC_GETNEXT = 1
Const HC_SKIP = 2
Const HC_NOREMOVE = 3
Const HC_NOREM = HC_NOREMOVE
Const HC_SYSMODALON = 4
Const HC_SYSMODALOFF = 5
' Virtual Key Codes (independent of left/right keys)
Private Const VK_SHIFT = &H10 ' Shift
Private Const VK_CONTROL = &H11 ' Ctrl
Private Const VK_MENU = &H12 ' Alt
' Custom constants for easier code reading
Private Const VK_CTRL = VK_CONTROL ' Ctrl
Private Const VK_ALT = VK_MENU ' Alt
' Low-Level Keyboard Constants
Private Const LLKHF_EXTENDED = &H1
Private Const LLKHF_INJECTED = &H10
Private Const LLKHF_ALTDOWN = &H20
Private Const LLKHF_UP = &H80
Public Const MASK_PRESSED = &H8000 ' 16th bit for key pressed
Public Const MASK_TOGGLE = &H1 ' 1st bit for key toggled e.g.Caps Lock, Num Lock, Scroll Lock
' ===========================================================================
' Purpose : Set up the keyboard hook , referencing the KeyHandler function.
' Return : True if successful.
' ===========================================================================
Public Function SetHook(Optional bVerbose As Boolean) As Boolean
Dim lThreadID As Long ' 32 bit DWORD regardless of 32/64 bit Office
On Error GoTo errorhandler
If Not GetPPTHandle Then Exit Function
' Don't set the same hook twice, as it cannot be released otherwise
If bIsHooked Or hHook > 0 Then UnHook
' Return the thread Id (as opposed to thread handle)
lThreadID = GetCurrentThreadId
' Set a local hook
hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, hWndPPT, lThreadID)
If hHook <> 0 Then
bIsHooked = True
SetHook = True
Debug.Print "Keyboard hooked: " & hHook
Else
Debug.Print "Keyboard hook failed"
End If
errorhandler:
If Err Then Debug.Print "Error setting the keyboard shortcut SetHook():" & Err & " " & Err.Description
On Error GoTo 0
End Function
' ===========================================================================
' Purpose : Sets the handle for the PowerPoint window.
' Return : True if successful
' ===========================================================================
Public Function GetPPTHandle() As Boolean
GetPPTHandle = True
hWndPPT = GetModuleHandle(vbNullString)
Debug.Print "hWndPPT: " & hWndPPT
If IsNull(hWndPPT) Then GetPPTHandle = False
End Function
' ===========================================================================
' Purpose : Main keyboard handler for defining the keyboard shortcuts.
' Iterative function to process multiple hook calls.
' Return :
' ===========================================================================
#If VBA7 Then
Private Function KeyboardProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
Private Function KeyboardProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Dim iShift As Integer
Dim iCtrl As Integer
Dim iAlt As Integer
Debug.Print "idHook: " & idHook & " | wParam: " & wParam & " | lParam: " & lParam
On Error GoTo errorhandler
' If idHook is less than zero, no further processing is required
If idHook < 0 Then
' Call the next hook
KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
Else
' If action and param then get the states of the SHIFT, CTRL, ALT keys
If idHook = HC_ACTION And lParam > 0 Then
iShift = GetKeyState(VK_SHIFT)
iCtrl = GetKeyState(VK_CTRL)
iAlt = GetKeyState(VK_ALT)
End If
' Check if specified key is pressed by testing the high-order bit of the short (16 bit) return value
' Test Shortcut: Ctrl + 3
If Not iShift And _
iCtrl And _
Not iAlt And _
GetKeyState(vbKey3) And _
MASK_PRESSED Then Debug.Print "Shortcut Ctrl+3": GoTo stopKeyHandler
' Call the next hook
KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
End If
Exit Function
stopKeyHandler:
' Return non-zero value to prevent processing further hooks in the chain
KeyboardProc = -1
Exit Function
errorhandler:
Debug.Print "Error in the keyboard shortcut KeyHandler():" & Err & " " & Err.Description
Resume Next
End Function
' ===========================================================================
' Purpose : Unhook the keyboard. (called by Auto_Close in production add-in)
' ===========================================================================
Public Function UnHook()
If hHook = 0 Then Exit Function
If UnhookWindowsHookEx(hHook) = 0 Then
Debug.Print "UnHook failed with error: " & Err.LastDllError
Else
Debug.Print "UnHook success"
bIsHooked = False
hHook = 0
End If
End Function
来源：https://stackoverflow.com/questions/56838395/windows-keyboard-hook-api-in-vba-causes-infinite-loop-in-powerpoint