VBA中的Windows键盘钩子API在PowerPoint中导致无限循环 [英] Windows keyboard hook API in VBA causes infinite loop in PowerPoint
本文介绍了VBA中的Windows键盘钩子API在PowerPoint中导致无限循环的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我构建了一个简单的VBA模块来设置键盘钩子，并构建了一个相应的过程来检测预定义的组合键(ctrl+3)。它工作得很好，只是当用户尝试在托管应用程序(PowerPoint)的窗口中键入内容时，代码会进入无限循环，导致应用程序挂起/崩溃。以下是带有再现说明的完整模块：
' ===========================================================================
' 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
推荐答案
我通过在KeyboardProc函数内将If idHook < 0 Then更改为If idHook <> 0 Then解决了无限循环问题。
如果查找KeyboardProc call back function的MSDN引用，它会注意到code参数(在您的示例中为idHook)有两个可能的值：
hc_action=0 wParam和lParam参数包含信息 关于击键消息。 HC_NOREMOVE=3 wParam和lParam参数包含信息 有关击键消息，而击键消息尚未 从消息队列中删除。(一个名为PeekMessage的应用程序 函数，指定PM_NOREMOVE标志。)
我不清楚为什么这会导致无限循环，但是您应该忽略任何带有NC_NOREMOVE标志的消息。它可能与正在使用PM_NOREMOVE调用PeekMessage的任何其他应用程序的特定行为有关。
我认为在我的情况下应该归咎于激进的数据保护软件。
这篇关于VBA中的Windows键盘钩子API在PowerPoint中导致无限循环的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
