Add Shape overlay with action and send to back

[Paul_Hossler]

Thanks for the help -- incorporated your code into my working test. I'll play with it some more, and then add the macros to my general purpose add-in

Never even occurred to me to untick the advance on mouse click

The goal is to make a PP slide show with a main 'driver' slide that will branch to others, but return to the main slide. I've had bad luck doing that sort of stuff with action buttons, since I forget in the heat of presenting and just click the slide. This was just to make it a little more fool proof for me

I did add some support routines (temporarily add SlideID to each slide, delete them, etc.)

Expanded to SlideRange to do multiples

Option Explicit

Sub SlideID_Add()
    Dim oSlide As Slide
    Dim oShape As Shape
    
    If ActivePresentation Is Nothing Then Exit Sub
    
    For Each oSlide In ActivePresentation.Slides
        On Error Resume Next
        oSlide.Shapes("SlideID").Delete
        On Error GoTo 0
        
        With oSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, 100, 20)
            .Name = "SlideID"
            .Fill.ForeColor.RGB = RGB(255, 0, 0)
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            With .TextFrame.TextRange
                .Text = CStr(oSlide.SlideID)
                .Font.Name = "arial"
                .Font.Size = 8
                .Font.Color.RGB = RGB(0, 0, 0)
            End With
        End With
    Next
End Sub
Sub SlideID_Delete()
    Dim oSlide As Slide
    Dim oShape As Shape
    
    If ActivePresentation Is Nothing Then Exit Sub
    
    For Each oSlide In ActivePresentation.Slides
        On Error Resume Next
        oSlide.Shapes("SlideID").Delete
        On Error GoTo 0
    Next
End Sub

Sub Overlay_AddFront()
    Call pvtOverlayAdd(True)
End Sub
Sub Overlay_AddBack()
    Call pvtOverlayAdd(False)
End Sub
Sub Overlays_Delete()
    Dim oSlide As Slide
    Dim oShape As Shape
    
    If ActivePresentation Is Nothing Then Exit Sub
    
    For Each oSlide In ActivePresentation.Slides
        On Error Resume Next
        oSlide.Shapes("Foreground Overlay").Delete
        oSlide.Shapes("Background Overlay").Delete
        On Error GoTo 0
    Next
End Sub
 
Private Sub pvtOverlayAdd(ForeGround As Boolean)
    Dim oSlideLink As Slide
    Dim vSlideID As Variant
    Dim sLinkID As String, sLinkIndex As String, sLinkTitle As String
    Dim oSlideRange As SlideRange
    Dim iSlideRange As Long
    Dim eZorder As MsoZOrderCmd
    Dim sOverlay As String
    
    
    If ActivePresentation Is Nothing Then Exit Sub
    
    If ForeGround Then
        eZorder = msoBringToFront
        sOverlay = "Foreground Overlay"
    Else
        eZorder = msoSendToBack
        sOverlay = "Background Overlay"
    End If
    
    vSlideID = InputBox("Enter the SlideID of the slide for the " & sOverlay & " to link to", sOverlay, 0)
    If Len(vSlideID) = 0 Then Exit Sub
    
    Set oSlideLink = Nothing
    On Error Resume Next
    Set oSlideLink = ActivePresentation.Slides.FindBySlideID(CLng(vSlideID))
    On Error GoTo 0
    
    If oSlideLink Is Nothing Then
        Call MsgBox("'" & vSlideID & "' is not a valid slide ID. Try again", vbCritical + vbOKOnly, "Add Mask")
        Exit Sub
    End If
    
    
    Set oSlideRange = ActiveWindow.Selection.SlideRange
    
    For iSlideRange = 1 To oSlideRange.Count
        
        With oSlideRange(iSlideRange)
            On Error Resume Next
            .Shapes(sOverlay).Delete
            On Error GoTo 0
        
            With .Shapes.AddShape(msoShapeRectangle, 0, 0, ActivePresentation.PageSetup.SlideWidth, ActivePresentation.PageSetup.SlideHeight)
                
                .Name = sOverlay
                .Fill.Visible = False
                .Line.Visible = False
                .ZOrder (eZorder)
                
                sLinkID = CStr(oSlideLink.SlideID)
                sLinkIndex = CStr(oSlideLink.SlideIndex)
                Select Case oSlideLink.Shapes.HasTitle
                    Case Is = True
                        If oSlideLink.Shapes.Title.TextFrame.HasText Then
                            sLinkTitle = oSlideLink.Shapes.Title.TextFrame.TextRange
                        Else
                            sLinkTitle = "Slide " & CStr(oSlideLink.SlideIndex)
                        End If
                    Case Is = False
                        sLinkTitle = "Slide " & CStr(oSlideLink.SlideIndex)
                    End Select
        
                With .ActionSettings(ppMouseClick)
                    .Action = ppActionHyperlink
                    .Hyperlink.SubAddress = sLinkID & "," & sLinkIndex & "," & sLinkTitle
                End With
            End With
        End With
    Next
End Sub