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