Display message in Slide Show

The first macro pauses the show and asks what needs to be shown, then displays it.
The second removes the display. Having this removal as a separate macro allows you to keep the message up as long or as short a time as is required.
So, add shortcuts to this pair of macros (ShowMe and HideMe) on any toolbar and click on one to add your message and the other to remove it.


Please note that these macros are not fool-proof. I have not trapped possible errors, like removing messages that are not there, or adding messages on to existing messages. You can add these routines should you feel the need.


Sub ShowMe() 

Dim Msg As String, Sld As Integer, x As Integer

Msg = InputBox("What do you want to be displayed?", "Urgent Message")
     If Trim(Msg) = "" Then Exit Sub

Sld = SlideShowWindows(1).View.CurrentShowPosition

ActivePresentation.Slides(Sld).Shapes _
     .AddTextbox(msoTextOrientationHorizontal, _
     Left:=0, Top:=-50, Width:=ActivePresentation _
     .PageSetup.SlideWidth, Height:=50).Name = "Emergent"

With ActivePresentation.Slides(Sld).Shapes("Emergent")
     With .Fill
          .ForeColor.RGB = RGB(255, 0, 0)
          .OneColorGradient msoGradientHorizontal, 4, 0
          End With
     With .TextFrame.TextRange
          .ParagraphFormat.Alignment = ppAlignCenter
          .Text = Msg
          .Font.Size = 35
          .Font.Color.RGB = RGB(255, 240, 240)
          End With
     For x = -50 To 0
          .Top = x
          DoEvents
          Next x
     .Copy
End With

For x = 1 To ActivePresentation.Slides.Count
     If x <> Sld Then
          ActivePresentation.Slides(x).Shapes.Paste
          End If
     Next x

SlideShowWindows(1).Activate

End Sub

Sub HideMe() 
Dim x As Integer, y As Integer, Sld As Integer

Sld = ActivePresentation.SlideShowWindow.View.CurrentShowPosition

For x = 1 To ActivePresentation.Slides.Count
         With ActivePresentation.Slides(x).Shapes("Emergent")
               If x = Sld Then
                    For y = 0 To -50 Step -1
                         .Top = y
                         DoEvents
                         Next y
                    End If
               .Delete
          End With
     Next x

SlideShowWindows(1).Activate

End Sub


© 2022 Better Solutions Limited. All Rights Reserved. © 2022 Better Solutions Limited TopPrev