vbapowerpoint

Utilising CommandButton1_KeyDown across all PowerPoint Slides


PowerPoint Slides

I have 4 slides with an ActiveX Label in each of the slides. The first slide contains an ActiveX Command Button.

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

This code allows me to capture the keypress and run the corresponding macro. To start capturing the keypresses, I would have to first click on the Command Button present in Slide 1. After that, the code does its job wonderfully. However, the code would not work if I go to another slide. The keypress capture occurs only in Slide 1. I assume it has to do with the Private Sub present within Slide1

I'm stuck at replicating the same as I navigate through slides 1 to 4. I do not want to place a command button on every slide. I would like for vbKeyA to be captured across all slides and run the corresponding macro.

Please advise the best method to proceed.


Solution

  • Your approach works because when you click the button for the first time, it gets the focus. As long as the button has the focus, the KeyDown event will trigger. As soon as the button loses focus the event will not trigger anymore. Once you change slide the button on the first slide loses focus.

    The comment provided by @DanielDuĊĦek is sensible. Using this approach, you need a control that exposes a KeyDown event in order to trap it and unfortunately you would need such a control to always have the focus, hence one on each slide. Could be a Frame, TextBox, CommandButton etc.

    Initial approach - you can skip this section

    My initial approach was to try to improve on your approach. Main steps:

    1. At the click of the initial button I've programmatically added a transparent button on each slide using Slide.Shapes.AddOLEObject ClassName:="Forms.CommandButton.1"
    2. I've retrieved each button using the shape returned by AddOLEObject with: Shape.OLEFormat.Object
    3. I added each button in a wrapper class so I can trap the KeyDown events
    4. I edited each button (like making it transparent)
    5. I then added all wrapped buttons to a global collection so I can remove them later.

    I encountered 2 issues:

    1. I was not able to programatically set the focus on the transparent buttons (BTW it seems the slide app events are not firing properly - yes, I had a wrapper WithEvents application class as well). Even if this worked the control can still lose focus so it wouldn't be too reliable
    2. The wrapped buttons seemed to lose state (although the global collection had a reference to each) and I could not remove them later

    Overall the above approach is horrible and unreliable.

    Actual solution

    Instead of relying on controls with events I proceeded to hook into the keyboard itself. The following solution will only work on Windows (not on a Mac). As far as I tested it works well.

    Drop the following code into a standard module. Call it 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
    

    All you need to do to start tracking key presses is to call the the HookKeyboard method once the presentation has started. You can do that in a few ways. Here are 2:

    1. Press Alt+F8 (Macro Dialog Box) and then run the Macro directly
    2. Use an ActiveX button on the first slide:
    Private Sub CommandButton1_Click()
        HookKeyboard
    End Sub
    

    Important! I've written the code in such a way that it hooks only if the presentation is already started at the moment you call it. Also, it automatically unhooks when the presentation is over (at any key press). If you want to stop the hook before the presentation ends then simply call the UnHookKeyboard method.

    Currently, the above code will only display some info in the Immediate Window whenever you press the A key:
    enter image description here

    All you need to do is to go to the KeyboardProc method and change these lines:

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

    enter image description here

    to whatever you need. I suppose you will simply call you desired macro.