Windows keyboard hook API in VBA causes infinite loop in PowerPoint

匆匆过客 提交于 2020-03-05 02:52:49

问题


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

易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!