A
anonymous
I have written a simple VBA macro that creates a tool bar. Using the tool
bar shapes can be programmed as hotspots (ActionSettings). Clicking the
hotspot takes an image of another slide and displays its like a popup or
overlay on the current slide.
This approach of viewing slides allows the presenter to stay on 1 main slide
and popup or overlay others containing more details. The presenter doesn't
have to navigate through the full series of slides to locate a related slide.
I am posting my code in the hope it will be of use to others and that
someone out there can provide enhancements.
Areas of feedback/enhancement I am looking for are :-
1. saving macros in PPA while still having direct access to the
"DisplayImageOfSlide" macro from PPT files
2. developing a macro that writes new macros
3. replacing the MsgBox prompts with a pretty form
--->code snipet<---
Option Explicit
Sub Aut
pen()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
'Give the toolbar a name
MyToolbar = "DisplayImageOfSlideBar"
'First, delete the toolbar if it already exists
For Each oToolbar In Application.CommandBars
If oToolbar.Name = MyToolbar Then
oToolbar.Delete
End If
Next oToolbar
'Build the command bar
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, _
Temporary:=True)
'Now add a Save selection button
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Show SlideID"
.Caption = "Show SlideID"
.OnAction = "ShowSlideID"
.Style = msoButtonIconAndCaption
.FaceId = 455
End With
'Now add a Linked summary slide button
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Show Shape Position"
.Caption = "Show Shape Position"
.OnAction = "ShowShapePosition"
.Style = msoButtonIconAndCaption
.FaceId = 312
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Add Action"
.Caption = "Add Action"
.OnAction = "AddAction"
.Style = msoButtonIconAndCaption
.FaceId = 4308
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Remove Action"
.Caption = "Remove Action"
.OnAction = "RemoveAction"
.Style = msoButtonIconAndCaption
.FaceId = 4308
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Describe commands"
.Caption = "Help"
.OnAction = "DisplayHelp"
.Style = msoButtonIconAndCaption
.FaceId = 345
End With
'Place Toolbar
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
End Sub
Sub Auto_Close()
'Get rid of the Toolbar
Dim oToolbar As CommandBar
For Each oToolbar In Application.CommandBars
If oToolbar.Name = "SelectionSaveBar" Then _
oToolbar.Delete
Next oToolbar
End Sub
' *********************************************************************
Sub ShowSlideID()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionSlides Then
MsgBox "No slide selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
MsgBox " SlideID: " & ActiveWindow.Selection.SlideRange.SlideID
End Sub
' *********************************************************************
Sub ShowShapePosition()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
With ActiveWindow.Selection.ShapeRange(1)
MsgBox .Name & " Left: " & .Left & " Top: " & .Top
End With
End Sub
' *********************************************************************
Sub AddAction()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
Dim lSlideID, lTopOffset, lLeftOffset, lScale
lSlideID = InputBox("Enter SlideID :")
lLeftOffset = InputBox("Enter offset from Left :")
lTopOffset = InputBox("Enter offset from Top :")
lScale = InputBox("Enter Scale :")
With ActiveWindow.Selection.ShapeRange
.Select
.AlternativeText = lSlideID & "," & lLeftOffset & "," & lTopOffset &
"," & lScale
With .ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "DisplayImageOfSlide"
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
End Sub
' *********************************************************************
Sub RemoveAction()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
With ActiveWindow.Selection.ShapeRange
.Select
.AlternativeText = ""
With .ActionSettings(ppMouseClick)
.Action = ppActionNone
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
End Sub
' *********************************************************************
Sub DisplayImageOfSlide(oSh As Shape)
'On Error GoTo Errorhandle:
Dim lArray() As String
Dim lSlideID As Long
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long
Dim oCurrentSlide As Slide
Dim oSourceSlide As Slide
Dim bMasterShapes As Boolean
Set oCurrentSlide = oSh.Parent
lArray = Split(oSh.AlternativeText, ",")
lSlideID = lArray(0)
lLeft = lArray(1)
lTop = lArray(2)
lScale = lArray(3)
Set oSourceSlide = ActivePresentation.Slides.FindBySlideID(lSlideID)
With ActivePresentation
.Slides.FindBySlideID(lSlideID).Shapes.Range.Copy
With oCurrentSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Left = lLeft
.Top = lTop
.ScaleWidth (lScale / 100), msoFalse
.ScaleHeight (lScale / 100), msoFalse
With .ActionSettings(ppMouseClick)
.Run = "RemoveImageOfSlide"
.Action = ppActionRunMacro
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = ppForeground
.Line.BackColor.RGB = RGB(255, 255, 255)
.Line.Weight = 2.25
With .Fill
.Visible = oSourceSlide.Background.Fill.Visible
.ForeColor = oSourceSlide.Background.Fill.ForeColor
.BackColor = oSourceSlide.Background.Fill.BackColor
End With
Select Case oSourceSlide.Background.Fill.Type
Case Is = msoFillTextured
Select Case oSourceSlide.Background.Fill.TextureType
Case Is = msoTexturePreset
.Fill.PresetTextured
(oSourceSlide.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
End Select
Case Is = msoFillSolid
.Fill.Transparency = 0#
.Fill.Solid
Case Is = msoFillPicture
' No way to get the picture so export the slide image.
With oSourceSlide
If .Shapes.Count > 0 Then .Shapes.Range.Visible = False
bMasterShapes = .DisplayMasterShapes
.DisplayMasterShapes = False
.Export .SlideID & ".png", "PNG"
End With
.Fill.UserPicture oSourceSlide.SlideID & ".png"
Kill (oSourceSlide.SlideID & ".png")
With oSourceSlide
.DisplayMasterShapes = bMasterShapes
If .Shapes.Count > 0 Then .Shapes.Range.Visible = True
End With
Case Is = msoFillPatterned
.Fill.Patterned (oSourceSlide.Background.Fill.Pattern)
Case Is = msoFillGradient
Select Case oSourceSlide.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Fill.TwoColorGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Fill.PresetGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant, _
oSourceSlide.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Fill.OneColorGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant, _
oSourceSlide.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only applicable to shapes.
End Select
End With
End With
Exit Sub
Errorhandle:
Call DisplayHelp
On Error Resume Next
End Sub
' *********************************************************************
Sub RemoveImageOfSlide(oSh As Shape)
oSh.Delete
End Sub
' *********************************************************************
Sub DisplayHelp()
Dim sMessage As String
Dim Response
sMessage = "Usage:" & vbCr & _
" Assign the shape's MouseOver or MouseClick 'Action
Setting' as" & vbCr & _
" Run Macro: DisplayImageOfSlide" & vbCr & _
" Use the formatting dialog, Web Text tab to enter your
parameters" & vbCr & _
" ID = Value" & vbCr & _
" 0 = SlideIDx to display" & vbCr & _
" 1 = X offset" & vbCr & _
" 2 = Y offset" & vbCr & _
" 3 = Scale of image" & vbCr & _
" Example: 1,100,200,50 would display image of Slide
1" & vbCr & _
" at 100 from the left and 200
from top" & vbCr & _
" scaled down by 50%" & vbCr & _
" On playback, a popup will an image of the slide and
then disappear" & vbCr & _
" when you click the popup again."
Response = MsgBox(sMessage, vbOKOnly, "Display Image of Slide")
End Sub
--->code snipet<---
bar shapes can be programmed as hotspots (ActionSettings). Clicking the
hotspot takes an image of another slide and displays its like a popup or
overlay on the current slide.
This approach of viewing slides allows the presenter to stay on 1 main slide
and popup or overlay others containing more details. The presenter doesn't
have to navigate through the full series of slides to locate a related slide.
I am posting my code in the hope it will be of use to others and that
someone out there can provide enhancements.
Areas of feedback/enhancement I am looking for are :-
1. saving macros in PPA while still having direct access to the
"DisplayImageOfSlide" macro from PPT files
2. developing a macro that writes new macros
3. replacing the MsgBox prompts with a pretty form
--->code snipet<---
Option Explicit
Sub Aut
pen()Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
'Give the toolbar a name
MyToolbar = "DisplayImageOfSlideBar"
'First, delete the toolbar if it already exists
For Each oToolbar In Application.CommandBars
If oToolbar.Name = MyToolbar Then
oToolbar.Delete
End If
Next oToolbar
'Build the command bar
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, _
Temporary:=True)
'Now add a Save selection button
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Show SlideID"
.Caption = "Show SlideID"
.OnAction = "ShowSlideID"
.Style = msoButtonIconAndCaption
.FaceId = 455
End With
'Now add a Linked summary slide button
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Show Shape Position"
.Caption = "Show Shape Position"
.OnAction = "ShowShapePosition"
.Style = msoButtonIconAndCaption
.FaceId = 312
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Add Action"
.Caption = "Add Action"
.OnAction = "AddAction"
.Style = msoButtonIconAndCaption
.FaceId = 4308
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Remove Action"
.Caption = "Remove Action"
.OnAction = "RemoveAction"
.Style = msoButtonIconAndCaption
.FaceId = 4308
End With
'Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
'And set some of the button's properties
With oButton
.DescriptionText = "Describe commands"
.Caption = "Help"
.OnAction = "DisplayHelp"
.Style = msoButtonIconAndCaption
.FaceId = 345
End With
'Place Toolbar
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
End Sub
Sub Auto_Close()
'Get rid of the Toolbar
Dim oToolbar As CommandBar
For Each oToolbar In Application.CommandBars
If oToolbar.Name = "SelectionSaveBar" Then _
oToolbar.Delete
Next oToolbar
End Sub
' *********************************************************************
Sub ShowSlideID()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionSlides Then
MsgBox "No slide selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
MsgBox " SlideID: " & ActiveWindow.Selection.SlideRange.SlideID
End Sub
' *********************************************************************
Sub ShowShapePosition()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
With ActiveWindow.Selection.ShapeRange(1)
MsgBox .Name & " Left: " & .Left & " Top: " & .Top
End With
End Sub
' *********************************************************************
Sub AddAction()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
Dim lSlideID, lTopOffset, lLeftOffset, lScale
lSlideID = InputBox("Enter SlideID :")
lLeftOffset = InputBox("Enter offset from Left :")
lTopOffset = InputBox("Enter offset from Top :")
lScale = InputBox("Enter Scale :")
With ActiveWindow.Selection.ShapeRange
.Select
.AlternativeText = lSlideID & "," & lLeftOffset & "," & lTopOffset &
"," & lScale
With .ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "DisplayImageOfSlide"
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
End Sub
' *********************************************************************
Sub RemoveAction()
'If there isn't anything selected, then don't bother
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "No shape selected. Aborting.", vbCritical, "Selection Error"
Exit Sub
End If
With ActiveWindow.Selection.ShapeRange
.Select
.AlternativeText = ""
With .ActionSettings(ppMouseClick)
.Action = ppActionNone
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End With
End Sub
' *********************************************************************
Sub DisplayImageOfSlide(oSh As Shape)
'On Error GoTo Errorhandle:
Dim lArray() As String
Dim lSlideID As Long
Dim lScale As Long
Dim lLeft As Long
Dim lTop As Long
Dim oCurrentSlide As Slide
Dim oSourceSlide As Slide
Dim bMasterShapes As Boolean
Set oCurrentSlide = oSh.Parent
lArray = Split(oSh.AlternativeText, ",")
lSlideID = lArray(0)
lLeft = lArray(1)
lTop = lArray(2)
lScale = lArray(3)
Set oSourceSlide = ActivePresentation.Slides.FindBySlideID(lSlideID)
With ActivePresentation
.Slides.FindBySlideID(lSlideID).Shapes.Range.Copy
With oCurrentSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Left = lLeft
.Top = lTop
.ScaleWidth (lScale / 100), msoFalse
.ScaleHeight (lScale / 100), msoFalse
With .ActionSettings(ppMouseClick)
.Run = "RemoveImageOfSlide"
.Action = ppActionRunMacro
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = ppForeground
.Line.BackColor.RGB = RGB(255, 255, 255)
.Line.Weight = 2.25
With .Fill
.Visible = oSourceSlide.Background.Fill.Visible
.ForeColor = oSourceSlide.Background.Fill.ForeColor
.BackColor = oSourceSlide.Background.Fill.BackColor
End With
Select Case oSourceSlide.Background.Fill.Type
Case Is = msoFillTextured
Select Case oSourceSlide.Background.Fill.TextureType
Case Is = msoTexturePreset
.Fill.PresetTextured
(oSourceSlide.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
End Select
Case Is = msoFillSolid
.Fill.Transparency = 0#
.Fill.Solid
Case Is = msoFillPicture
' No way to get the picture so export the slide image.
With oSourceSlide
If .Shapes.Count > 0 Then .Shapes.Range.Visible = False
bMasterShapes = .DisplayMasterShapes
.DisplayMasterShapes = False
.Export .SlideID & ".png", "PNG"
End With
.Fill.UserPicture oSourceSlide.SlideID & ".png"
Kill (oSourceSlide.SlideID & ".png")
With oSourceSlide
.DisplayMasterShapes = bMasterShapes
If .Shapes.Count > 0 Then .Shapes.Range.Visible = True
End With
Case Is = msoFillPatterned
.Fill.Patterned (oSourceSlide.Background.Fill.Pattern)
Case Is = msoFillGradient
Select Case oSourceSlide.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Fill.TwoColorGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Fill.PresetGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant, _
oSourceSlide.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Fill.OneColorGradient _
oSourceSlide.Background.Fill.GradientStyle, _
oSourceSlide.Background.Fill.GradientVariant, _
oSourceSlide.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only applicable to shapes.
End Select
End With
End With
Exit Sub
Errorhandle:
Call DisplayHelp
On Error Resume Next
End Sub
' *********************************************************************
Sub RemoveImageOfSlide(oSh As Shape)
oSh.Delete
End Sub
' *********************************************************************
Sub DisplayHelp()
Dim sMessage As String
Dim Response
sMessage = "Usage:" & vbCr & _
" Assign the shape's MouseOver or MouseClick 'Action
Setting' as" & vbCr & _
" Run Macro: DisplayImageOfSlide" & vbCr & _
" Use the formatting dialog, Web Text tab to enter your
parameters" & vbCr & _
" ID = Value" & vbCr & _
" 0 = SlideIDx to display" & vbCr & _
" 1 = X offset" & vbCr & _
" 2 = Y offset" & vbCr & _
" 3 = Scale of image" & vbCr & _
" Example: 1,100,200,50 would display image of Slide
1" & vbCr & _
" at 100 from the left and 200
from top" & vbCr & _
" scaled down by 50%" & vbCr & _
" On playback, a popup will an image of the slide and
then disappear" & vbCr & _
" when you click the popup again."
Response = MsgBox(sMessage, vbOKOnly, "Display Image of Slide")
End Sub
--->code snipet<---