How can I automate the hiding of PowerPoint slides? - vba

Question

I use PowerPoint in my lectures and print a subset of the slides for my students (to allow them to fill in blanks before I show my answers). Currently, I put a light blue circle at the bottom left of slides that I want to hide while printing (but not while lecturing). I then manually hide slides when it is time to print them, then unhide all of the slides before lecturing. Is there any way to automate this process? I use Office 365 on both PCs and Macs.

Answer 1

This will get you started, save this as pptm then save a copy as addin:
ChangeAnswersSlideState - changes activeslide to be an Answer Slide or not
PrintStudentHandout - Hide Answer slides and then print, then unhide
Option Explicit
Private Const ANS_ID As String = "ANS"
Sub PrintStudentHandout()
ChangeAnswersSlideVisible
With ActivePresentation
.PrintOptions.ActivePrinter = "Microsoft XPS Document Writer"
.PrintOut
End With
ChangeAnswersSlideVisible msoFalse
End Sub
Private Sub ChangeAnswersSlideVisible(Optional Hide As MsoTriState = msoTrue)
Dim oSlide As Slide, oShp As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShp In oSlide.Shapes
If IsAnswersShape(oShp) Then
oSlide.SlideShowTransition.Hidden = Hide
Exit For
End If
Next oShp
Next oSlide
End Sub
Sub ChangeAnswersSlideState()
Dim oShp As Shape, bChanged As Boolean
bChanged = False
For Each oShp In Application.ActiveWindow.View.Slide.Shapes
If IsAnswersShape(oShp) Then
oShp.Delete
bChanged = True
End If
Next oShp
If Not bChanged Then MakeAnswersSlide
End Sub
Private Sub MakeAnswersSlide(Optional ByRef AnswerSlide As Slide = Nothing)
If AnswerSlide Is Nothing Then Set AnswerSlide = Application.ActiveWindow.View.Slide
With AnswerSlide.Shapes.AddShape(msoShapeOval, -80, 460, 72, 72)
.TextFrame.TextRange.Text = ANS_ID
End With
End Sub
Private Function IsAnswersShape(ByRef CheckShape As Shape) As Boolean
Dim bIsAnAnswerShape As Boolean
bIsAnAnswerShape = False
With CheckShape
If .AutoShapeType = msoShapeOval Then
If .HasTextFrame Then
If .TextFrame.TextRange.Text = ANS_ID Then
bIsAnAnswerShape = True
End If
End If
End If
End With
IsAnswersShape = bIsAnAnswerShape
End Function