ActivateShape

PowerPoint allows one to insert VBA controls on the slides but it doesn't provide any way to set focus on a particular VBA control. ActivateShape() subroutine enables you to do just that. Pass the VBA control shape as input to ActivateShape() and it will set the focus to that control.

Download the example presentation from hereDownload to see ActivateShape(), ActivateNextShape() and ActivatePreviousShape() in action.

Notes:

  • The code snippet demonstrates a way of getting the handle of any ActiveX control present on the slide. The function GetShapeHandle() returns the handle of the VBA control shape when given an approximate bounds of the shape.
  • Although you can set focus on any ActiveX control on the slide, ActivateShape() subroutine is designed to set the focus on VBA controls only. This is because I check for VBA control class "F3 Server 60000000" in the routine that gets the handle of the shape. For setting focus on Shockwave Flash Object, use "MacromediaFlashPlayerActiveX" as the value of VBA_CONTROL_CLASS.
  • ActivateShape() is designed to work during slide shows only.
  • ActivateShape() will not work with PowerPoint 97 or below because it uses the AddressOf operator that was introduced in PowerPoint 2000.
  • ActivateShape() will work on any VBA control including CheckBox, TextBox, CommandButton, OptionButton, ListBox, ComboBox, ToggleButton, SpinButton and ScrollBar.

See Also: ActivateNextShape(), ActivatePreviousShape()


'
' Copyright (C) 2002 OfficeOne
'

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 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 Const VBA_CONTROL_CLASS = "F3 Server 60000000"

Private ShapeRect As RECT
Private ShapeHandle As Long

Sub ActivateShape(ByVal Shp As Shape)
    Dim Pres As Presentation
    Dim SSW As SlideShowWindow
    Dim ScreenWidth As Long
    Dim ScreenHeight As Long
    Dim ShapeTop As Long
    Dim ShapeLeft As Long
    Dim ShapeWidth As Long
    Dim ShapeHeight As Long
    Dim SH As Long

    On Error Resume Next

    If Shp.Type = msoOLEControlObject Then
        Set Pres = Shp.Parent.Parent
        Set SSW = Pres.SlideShowWindow

        If Not (SSW Is Nothing) Then
            ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
            ScreenHeight = GetSystemMetrics(SM_CYSCREEN)

            ShapeTop = Shp.Top * ScreenHeight / Pres.PageSetup.SlideHeight
            ShapeLeft = Shp.Left * ScreenWidth / Pres.PageSetup.SlideWidth
            ShapeWidth = Shp.Width * ScreenWidth / Pres.PageSetup.SlideWidth
            ShapeHeight = Shp.Height * ScreenHeight / Pres.PageSetup.SlideHeight

            SH = GetShapeHandle(ShapeLeft, ShapeTop, ShapeWidth, ShapeHeight)
            If SH <> 0 Then
                SetFocus SH
            End If
        End If
    End If
End Sub

Function GetClassNameStr(ByVal WH As Long) As String
    Dim S As String
    Dim L As Long

    S = String(1024, Chr(0))
    L = GetClassName(WH, S, 1023)
    S = Left(S, L)
    GetClassNameStr = S
End Function

Function EnumChildWindowsFunc(ByVal ChildWH As Long, _
    Param As Long) As Boolean

    Dim ChildWR As RECT
    Dim ClassName As String

    EnumChildWindowsFunc = True

    If GetWindowRect(ChildWH, ChildWR) <> 0 Then
        If (Abs(ShapeRect.Left - ChildWR.Left) <= 1) And _
            (Abs(ShapeRect.Top - ChildWR.Top) <= 1) And _
            (Abs(ShapeRect.Right - ChildWR.Right) <= 1) And _
            (Abs(ShapeRect.Bottom - ChildWR.Bottom) <= 1) Then

            ClassName = GetClassNameStr(ChildWH)
            If ClassName = VBA_CONTROL_CLASS Then
                ShapeHandle = ChildWH
                EnumChildWindowsFunc = False
            End If
        End If
    Else
        EnumChildWindowsFunc = False
    End If
End Function

Function GetShapeHandle(ByVal ShapeLeft As Long, _
    ByVal ShapeTop As Long, _
    ByVal ShapeWidth As Long, _
    ByVal ShapeHeight As Long) As Long

    Dim WH As Long

    ShapeRect.Left = ShapeLeft
    ShapeRect.Top = ShapeTop
    ShapeRect.Right = ShapeLeft + ShapeWidth
    ShapeRect.Bottom = ShapeTop + ShapeHeight
    ShapeHandle = 0

    WH = GetForegroundWindow()
    EnumChildWindows WH, AddressOf EnumChildWindowsFunc, 0
    GetShapeHandle = ShapeHandle
End Function

Contact OfficeOne on email at officeone@officeoneonline.com. Copyright © 2001-2023 OfficeOne. All rights reserved.