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
here
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
|
|