Home Up Updates Add-ins Fun Stuff

Bill's Message during show ...
 

 

Home
Up

 

 

 

Microsoft  PowerPoint MVP 2003-2007

 

    So, you are running a show in dual screen mode and George, the guy in charge of the child care room, comes up and asks you to get Mr. & Mrs. Smith right now, 'cause Jimmy had an accident.  Pop Quiz, what do you do?

    You don't want to interrupt everything and announce over the PA that a kid is hurt.  No parent in the audience will hear another word that is said.  In addition, the mood the presenter has been carefully building, is now shattered.  Announcements are just ugly solutions.

    Enter in this little pair of macros:

  •    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.

Option Explicit

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

 

Home ] Up ]

Send mail to BillDilworth@mvps.org with questions or comments about this web site.
Copyright 2004-2007 Bill Dilworth
Last modified: 06/12/07