在所有 PowerPoint 幻灯片中使用 CommandButton1_KeyDown

问题描述 投票：0回答：2

PowerPoint Slides

我有 4 张幻灯片，每张幻灯片中都有一个 ActiveX 标签。第一张幻灯片包含一个 ActiveX 命令按钮。

Private Sub CommandButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

Set shpPoint = ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox 1")

If (KeyCode = vbKeyA) Then 
Point = Point + 1
shpPoint.TextFrame.TextRange = Point
End If

End Sub

这段代码允许我捕获按键并运行相应的宏。要开始捕获按键，我必须首先单击幻灯片 1 中的命令按钮。之后，代码就可以出色地完成其工作。但是，如果我转到另一张幻灯片，该代码将无法工作。按键捕获仅发生在幻灯片 1 中。我认为它与 

Private Sub
 中存在的
Slide1

有关

在浏览幻灯片 1 到 4 时，我一直在重复相同的内容。我不想在每张幻灯片上放置命令按钮。我希望在所有幻灯片中捕获 vbKeyA 并运行相应的宏。

请告知最佳的操作方法。

vba powerpoint
2个回答
4
投票

您的方法有效，因为当您第一次单击按钮时，它会获得焦点。只要按钮获得焦点，就会触发 

KeyDown
事件。一旦按钮失去焦点，事件将不再触发。一旦您更改幻灯片，第一张幻灯片上的按钮就会失去焦点。

@DanielDušek 提供的评论是明智的。使用这种方法，您需要一个公开 

KeyDown
事件的控件以便捕获它，不幸的是您需要这样的控件来始终获得焦点，因此每张幻灯片上都有一个。可能是 
Frame
、
TextBox
、
CommandButton
等

初始方法 - 您可以跳过本节

我最初的方法是尝试改进您的方法。主要步骤：

  1. 单击初始按钮时，我使用 
    Slide.Shapes.AddOLEObject ClassName:="Forms.CommandButton.1"
    2. 以编程方式在每张幻灯片上添加了一个透明按钮
  2. 我使用 
    AddOLEObject
    返回的形状检索了每个按钮：
    Shape.OLEFormat.Object
  3. 我在包装类中添加了每个按钮，这样我就可以捕获 
    KeyDown
    事件
  4. 我编辑了每个按钮（比如使其透明）
  5. 然后，我将所有包装按钮添加到全局集合中，以便稍后删除它们。

我遇到了 2 个问题：

  1. 我无法以编程方式将焦点设置在透明按钮上（顺便说一句，幻灯片应用程序事件似乎没有正确触发 - 是的，我也有一个包装器
    WithEvents
    应用程序类）。即使这有效，控制仍然会失去焦点，所以它不会太可靠
  2. 包裹的按钮似乎失去了状态（尽管全局集合对每个按钮都有引用），我以后无法删除它们

总的来说，上述方法是可怕且不可靠的。

实际解决方案

我不再依赖带有事件的控件，而是继续连接键盘本身。以下解决方案仅适用于 Windows（不适用于 Mac）。据我测试，效果很好。

将以下代码放入标准模块中。就叫它

KeyboardHook
：

Option Explicit

'API declarations
#If Mac Then
    'No Mac functionality implemented
#Else 'Windows API functionality
    #If VBA7 Then
        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 GetCurrentThreadId Lib "kernel32" () As Long
        Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
        Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
        Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
        Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd 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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    #Else
        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 GetCurrentThreadId Lib "kernel32" () As Long
        Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
        Private Declare Function GetActiveWindow Lib "user32" () As Long
        Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
        Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd 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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    #End If
#End If

'Id of the hook procedure to be installed with SetWindowsHookExA for KeyboardProc
Private Const WH_KEYBOARD As Long = 2

'Hook handle returned by SetWindowsHookEx. Used later in UnhookWindowsHookEx
#If VBA7 Then
    Private m_hHookKeyboard As LongPtr
#Else
    Private m_hHookKeyboard As Long
#End If

'Stored to check if presentation is still running via 'IsPresentationActive'
Private m_presentation As Presentation

Private Const REG_APP As String = "PP"
Private Const REG_SECTION As String = "KeyHook"
Private Const REG_KEY As String = "hHook"

Private Function IsPresentationActive() As Boolean
    On Error Resume Next
    IsPresentationActive = ActivePresentation.SlideShowWindow.Active
    IsPresentationActive = (Err.Number = 0)
    On Error GoTo 0
End Function

'*******************************************************************************
'Hooks Keyboard messages
'*******************************************************************************
Public Sub HookKeyboard()
    UnHookKeyboard 'Remove previous hook
    '
    Set m_presentation = ActivePresentation
    If Not IsPresentationActive Then Exit Sub
    '
    Dim isHookSuccessful As Boolean
    '
    #If Mac Then
    #Else
        m_hHookKeyboard = SetWindowsHookEx(idHook:=WH_KEYBOARD _
                                         , lpfn:=AddressOf KeyboardProc _
                                         , hmod:=0 _
                                         , dwThreadId:=GetCurrentThreadId())
    #End If
    If m_hHookKeyboard <> 0 Then
        SaveSetting REG_APP, REG_SECTION, REG_KEY, m_hHookKeyboard
        Debug.Print "Keyboard hooked " & Now
    End If
End Sub

'*******************************************************************************
'UnHooks Keyboard
'*******************************************************************************
Public Sub UnHookKeyboard()
    If m_hHookKeyboard = 0 Then 'Try to restore if state was lost
        Dim savedHook As String
        '
        savedHook = GetSetting(REG_APP, REG_SECTION, REG_KEY)
        If savedHook <> vbNullString Then
            #If VBA7 Then
                m_hHookKeyboard = CLngPtr(savedHook)
            #Else
                m_hHookKeyboard = CLng(savedHook)
            #End If
        End If
    End If
    '
    If m_hHookKeyboard <> 0 Then
        #If Mac Then
        #Else
            UnhookWindowsHookEx m_hHookKeyboard
        #End If
        m_hHookKeyboard = 0
        DeleteSetting REG_APP, REG_SECTION, REG_KEY
        Debug.Print "Keyboard unhooked " & Now
    End If
End Sub

'*******************************************************************************
'Callback hook function - monitors keyboard messages
'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/ms644984(v=vs.85)
'*******************************************************************************
#If Mac Then
#Else
#If VBA7 Then
Private Function KeyboardProc(ByVal ncode As Long _
                            , ByVal wParam As Long _
                            , ByVal lParam As Long) As LongPtr
#Else
Private Function KeyboardProc(ByVal ncode As Long _
                            , ByVal wParam As Long _
                            , ByVal lParam As Long) As Long
#End If
    'nCode
    Const HC_ACTION As Long = 0
    Const HC_NOREMOVE As Long = 3
    '
    'WM_KEYUP/DOWN/CHAR HIWORD(lParam) flags
    Const KF_EXTENDED = &H100
    Const KF_DLGMODE = &H800
    Const KF_MENUMODE = &H1000
    Const KF_ALTDOWN = &H2000
    Const KF_REPEAT = &H4000
    Const KF_UP = &H8000
    '
    If IsVBEActive Then GoTo Unhook 'Unhook if a VBE window is active (to avoid crashes)
    If Not IsPresentationActive Then GoTo Unhook
    '
    If ncode = HC_ACTION Then
        If wParam = vbKeyA And (lParam And KF_UP) > 0 Then
            Debug.Print "A " & Now
            Debug.Print "Shift is down: " & IsShiftKeyDown()
            Debug.Print "Ctrl is down: " & IsControlKeyDown()
            Debug.Print
            '
            KeyboardProc = -1
            Exit Function
        End If
    End If
    '
NextHook:
    KeyboardProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)
Exit Function
Unhook:
    UnHookKeyboard
    GoTo NextHook
End Function
#End If

'*******************************************************************************
'Get Shift/Control Key State
'https://learn.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-getkeystate
'https://learn.microsoft.com/en-us/windows/desktop/inputdev/virtual-key-codes
'*******************************************************************************
Private Function IsShiftKeyDown() As Boolean
    Const VK_SHIFT As Long = &H10
    '
    IsShiftKeyDown = CBool(GetKeyState(VK_SHIFT) And &H8000) 'hi-order bit only
End Function
Private Function IsControlKeyDown() As Boolean
    Const VK_CONTROL As Long = &H11
    '
    IsControlKeyDown = CBool(GetKeyState(VK_CONTROL) And &H8000)
End Function

'*******************************************************************************
'Returns the String Caption of a Window identified by a handle
'*******************************************************************************
#If VBA7 Then
    Private Function GetWindowCaption(ByVal hwnd As LongPtr) As String
#Else
    Private Function GetWindowCaption(ByVal hwnd As Long) As String
#End If
    Dim bufferLength As Long: bufferLength = GetWindowTextLength(hwnd)
    GetWindowCaption = VBA.Space$(bufferLength)
    GetWindowText hwnd, GetWindowCaption, bufferLength + 1
End Function

'*******************************************************************************
'Checks if the ActiveWindow is a VBE Window
'*******************************************************************************
Private Function IsVBEActive() As Boolean
    #If Mac Then
    #Else
    IsVBEActive = VBA.InStr(1, GetWindowCaption(GetActiveWindow()) _
        , "Microsoft Visual Basic", vbTextCompare) <> 0
    #End If
End Function

要开始跟踪按键，您所需要做的就是在演示开始后调用 

HookKeyboard
方法。您可以通过几种方式做到这一点。这里有2个：

  1. 按 Alt+F8（宏对话框），然后直接运行宏
  2. 使用第一张幻灯片上的 ActiveX 按钮：
Private Sub CommandButton1_Click()
    HookKeyboard
End Sub

重要！我编写代码的方式是，仅当您调用它时演示文稿已经开始时，它才会挂钩。此外，当演示结束时（按任意键），它会自动取消挂钩。如果您想在演示结束之前停止挂钩，只需调用 

UnHookKeyboard
方法即可。

目前，上述代码只会在按下 A 键时在立即窗口中显示一些信息：
enter image description here

您需要做的就是转到 

KeyboardProc
方法并更改这些行：

Debug.Print "A " & Now
Debug.Print "Shift is down: " & IsShiftKeyDown()
Debug.Print "Ctrl is down: " & IsControlKeyDown()
Debug.Print

enter image description here

无论你需要什么。我想你会简单地调用你想要的宏。

0
投票

有没有人找到一种方法可以在不处于演示模式的情况下使用上述相同的模块？我需要在功能区中使用它；但一旦它发现它不处于呈现模式，它就会退出。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.