Activate textbox (activex control) on the slide during slide show and tab through them

OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Supported versions: PowerPoint 2010+ (32/64-bit) Download Source Presentation

There are some challeges to setting the focus on a MS Form text box control programmatically during a slide show and we address them here. For the purposes of this exampe, the scenario we shall look at is to run the slide show in full screen mode on the primary monitor. The approach will be to detect the textbox on the slide and then calculate its dimensions in the slide show window. Then we shall compare that size against all child windows on the slide show window and arrive at a match to get the window handle of the control and then set focus on it.

The slide size aspect ratio may not match the screen size aspect ratio so we will need to calculate the offset for such cases to arrive at the precise dimension of the shape in the slide show window. While this example considers only textboxes the same approach can be taken to handle out controls which don't have a Hwnd property. The diagram below illustrates how slides of different sizes will appear on a 16:10 monitor and the dimensions referenced in the example.


Screen 16:10 with Slide size 16:10	Screen 16:10 with Slide size 16:9	Screen 16:10 with Slide size 4:3

In order to track slide changes we need to hook into PowerPoint application events, the code for which is available in the source pptm or use an legacy auto macro. Each time a new slide is displayed, we can enumarate through the shapes and activate the first available textbox see FindFirstTextboxControlAndSetFocus method. Similarly FindNextTextboxControlAndSetFocus and FindPreviousTextboxControlAndSetFocus are used to cycle through all the textboxes on the slide using Tab and Shift+Tab respectively, the keyboard up event invokes these methods. Checkout the underlying code of slide 3 to see how the code is setup to enable tabbing between the controls.

' --------------------------------------------------------------------------------
' Copyright ©1999-2018, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or 
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' -------------------------------------------------------------------------------

#If Win64 Then
    Public Declare PtrSafe Function GetForegroundWindow Lib "user32.dll" () As LongPtr
    Public Declare PtrSafe Function SetFocus Lib "user32" (ByVal Hwnd As LongPtr) As Long
    Public Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As Long
    Public Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
    Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal Hwnd As LongPtr, lpRect As RECT) As Long
    Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Public Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
    Public Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long

    Private ShapeHwnd As LongPtr
#Else
    Public Declare Function GetForegroundWindow Lib "user32" () As Long
    Public Declare Function SetFocus Lib "user32" (ByVal Hwnd As Long) As Long
    Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Public Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Public Declare Function GetWindowRect Lib "user32" (ByVal Hwnd As Long, lpRect As RECT) As Long
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
    
    Private ShapeHwnd As Long
#End If

Private Const VK_SHIFT = &H10&
Private Const KEYEVENTF_KEYUP = &H2&

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type POINTAPI
    x   As Long
    y   As Long
End Type

Public Const CLASS_NAME_PATTERN = "F3 Server*"
Public Const TEXTBOX_PROG_ID = "Forms.TextBox.1"

Private ShapeRect As RECT

Sub FindFirstTextboxControlAndSetFocus(sld As Slide)
    Dim shp As Shape
    
    Set shp = GetFirstAvailableTextboxControlShape(sld)
    
    If Not (shp Is Nothing) Then
        Call ActivateShape(shp)
        keybd_event VK_SHIFT, MapVirtualKey(VK_SHIFT, 0), 0, 0
        keybd_event VK_SHIFT, MapVirtualKey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0
    End If
    
End Sub

Sub FindPreviousTextboxControlAndSetFocus(ByVal CurrentShp As Shape)
    Dim shp As Shape
    Dim NextShape As Shape

    Set NextShape = GetPreviousAvailableTextboxControlShape(CurrentShp.Parent, CurrentShp.ZOrderPosition)
    
    If NextShape Is Nothing Then
        Set NextShape = GetFirstAvailableTextboxControlShapeFromBottom(CurrentShp.Parent, CurrentShp.ZOrderPosition)
    End If
    
    If Not (NextShape Is Nothing) Then
        ActivateShape NextShape
        keybd_event VK_SHIFT, MapVirtualKey(VK_SHIFT, 0), 0, 0
    End If
End Sub

Sub FindNextTextboxControlAndSetFocus(ByVal CurrentShp As Shape)
    Dim shp As Shape
    Dim NextShape As Shape

    Set NextShape = GetNextAvailableTextboxControlShape(CurrentShp.Parent, CurrentShp.ZOrderPosition)
    
    If NextShape Is Nothing Then
        Set NextShape = GetFirstAvailableTextboxControlShape(CurrentShp.Parent, CurrentShp.ZOrderPosition)
    End If
    
    If Not (NextShape Is Nothing) Then
        ActivateShape NextShape
        keybd_event VK_SHIFT, MapVirtualKey(VK_SHIFT, 0), 0, 0
        keybd_event VK_SHIFT, MapVirtualKey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0
    End If
End Sub

Function GetFirstAvailableTextboxControlShape(sld As Slide, Optional currentZOrderPosition As Long = -1) As Shape
    Dim shp As Shape
    Dim NextShp As Shape
    Dim NextZPosition As Long
    Dim i As Long
    
    If currentZOrderPosition = -1 Then
        currentZOrderPosition = sld.Shapes.Count + 1
    End If
    
    For i = 1 To currentZOrderPosition - 1
        Set shp = sld.Shapes(i)
        If shp.Type = msoOLEControlObject Then
            If shp.OLEFormat.ProgID = TEXTBOX_PROG_ID Then
                Set GetFirstAvailableTextboxControlShape = shp
                Exit Function
            End If
        End If
    Next
End Function

Function GetPreviousAvailableTextboxControlShape(sld As Slide, currentZOrderPosition As Long) As Shape
    Dim shp As Shape
    Dim NextShp As Shape
    Dim NextZPosition As Long
    Dim i As Long
    
    For i = currentZOrderPosition - 1 To 1 Step -1
        Set shp = sld.Shapes(i)
        If shp.Type = msoOLEControlObject Then
            If shp.OLEFormat.ProgID = TEXTBOX_PROG_ID Then
                Set GetPreviousAvailableTextboxControlShape = shp
                Exit Function
            End If
        End If
    Next
End Function

Function GetNextAvailableTextboxControlShape(sld As Slide, currentZOrderPosition As Long) As Shape
    Dim shp As Shape
    Dim NextShp As Shape
    Dim NextZPosition As Long
    Dim i As Long
    
    For i = currentZOrderPosition + 1 To sld.Shapes.Count
        Set shp = sld.Shapes(i)
        If shp.Type = msoOLEControlObject Then
            If shp.OLEFormat.ProgID = TEXTBOX_PROG_ID Then
                Set GetNextAvailableTextboxControlShape = shp
                Exit Function
            End If
        End If
    Next
End Function

Function GetFirstAvailableTextboxControlShapeFromBottom(sld As Slide, currentZOrderPosition As Long) As Shape
    Dim shp As Shape
    Dim NextShp As Shape
    Dim NextZPosition As Long
    Dim i As Long
    
    For i = sld.Shapes.Count To currentZOrderPosition + 1 Step -1
        Set shp = sld.Shapes(i)
        If shp.Type = msoOLEControlObject Then
            If shp.OLEFormat.ProgID = TEXTBOX_PROG_ID Then
                Set GetFirstAvailableTextboxControlShapeFromBottom = shp
                Exit Function
            End If
        End If
    Next
End Function

#If Win64 Then
    Function EnumChildWindowsHandles(ByVal ChildHwnd As LongPtr, Param As Long) As Boolean
#Else
    Function EnumChildWindowsHandles(ByVal ChildHwnd As Long, Param As Long) As Boolean
#End If
    
    Dim r As RECT

    EnumChildWindowsHandles = True

    If GetWindowRect(ChildHwnd, r) <> 0 Then
        
        If GetWindowClassName(ChildHwnd) Like CLASS_NAME_PATTERN Then
            
            If IsMatchingRectangle(ShapeRect, r) Then
                    ShapeHwnd = ChildHwnd
                    EnumChildWindowsHandles = False
            End If
        End If
    Else
        EnumChildWindowsHandles = False
    End If
End Function

Function IsMatchingRectangle(ShapeRect As RECT, WindowRect As RECT) As Boolean
    If (Abs(ShapeRect.Left - WindowRect.Left) <= 1) And _
        (Abs(ShapeRect.Top - WindowRect.Top) <= 1) And _
        (Abs(ShapeRect.Right - WindowRect.Right) <= 1) And _
        (Abs(ShapeRect.Bottom - WindowRect.Bottom) <= 1) Then
        
        IsMatchingRectangle = True
    End If
End Function

#If Win64 Then
    Function GetShapeHandle() As LongPtr
    Dim Hwnd As LongPtr
#Else
    Function GetShapeHandle() As Long
    Dim Hwnd As Long
#End If
        
        Hwnd = GetForegroundWindow() ' Assuming that active window is the slideshow window
        
        EnumChildWindows Hwnd, AddressOf EnumChildWindowsHandles, 0
        
        GetShapeHandle = ShapeHwnd
    End Function

#If Win64 Then
    Function GetWindowClassName(ByVal Hwnd As LongPtr) As String
#Else
    Function GetWindowClassName(ByVal Hwnd As Long) As String
#End If
        Dim s As String
        Dim l As Long
    
        s = Space(255)
        l = GetClassName(Hwnd, s, 255)
        s = Left(s, l)
        
        GetWindowClassName = s
    End Function
    
Sub ActivateShape(ByVal shp As Shape)
    Dim Pres As Presentation
    Dim SlideShowWnd As SlideShowWindow
    
    Dim ShapeTop As Long
    Dim ShapeLeft As Long
    Dim ShapeWidth As Long
    Dim ShapeHeight As Long

    On Error Resume Next

    If shp.Type = msoOLEControlObject Then
        
        Set Pres = shp.Parent.Parent
        Set SlideShowWnd = Pres.SlideShowWindow
        If Not (SlideShowWnd) Then
            'Rendered shape dimensions during the slide show
            ShapeLeft = shp.Left * SlideShowSlideWidth / Pres.PageSetup.SlideWidth
            ShapeTop = shp.Top * SlideShowSlideHeight / Pres.PageSetup.SlideHeight
            ShapeWidth = shp.Width * SlideShowSlideWidth / Pres.PageSetup.SlideWidth
            ShapeHeight = shp.Height * SlideShowSlideHeight / Pres.PageSetup.SlideHeight
            
            'Offset shape position
            ShapeLeft = ShapeLeft + GetSlideOffsetOnScreen.x
            ShapeTop = ShapeTop + GetSlideOffsetOnScreen.y
            
            'Shape bounding rectangle
            ShapeRect.Left = ShapeLeft
            ShapeRect.Top = ShapeTop
            ShapeRect.Right = ShapeLeft + ShapeWidth
            ShapeRect.Bottom = ShapeTop + ShapeHeight
    
            ShapeHwnd = GetShapeHandle()
            
            If ShapeHwnd <> 0 Then
                SetFocus ShapeHwnd
            End If
        End If
    End If
End Sub

Function GetSlideOffsetOnScreen() As POINTAPI
    Dim Offset As POINTAPI
    
    Offset.x = (ScreenWidth - SlideShowSlideWidth) / 2
    Offset.y = (ScreenHeight - SlideShowSlideHeight) / 2
    
    GetSlideOffsetOnScreen = Offset
End Function

Function SlideShowSlideWidth() As Long
    If ScreenAspectRatio > SlideAspectRatio Then
        SlideShowSlideWidth = ScreenHeight * SlideAspectRatio
    Else
        SlideShowSlideWidth = ScreenWidth
    End If
End Function

Function SlideShowSlideHeight() As Long
    If ScreenAspectRatio > SlideAspectRatio Then
        SlideShowSlideHeight = ScreenHeight
    Else
        SlideShowSlideHeight = ScreenWidth / SlideAspectRatio
    End If
End Function

Public Property Get ScreenWidth() As Long
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Property

Public Property Get ScreenHeight() As Long
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Property

Public Property Get SlideAspectRatio() As Single
    With SlideShowWindows(1).Presentation.PageSetup
        SlideAspectRatio = .SlideWidth / .SlideHeight
    End With
End Property

Public Property Get ScreenAspectRatio() As Single
    ScreenAspectRatio = ScreenWidth / ScreenHeight
End Property