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
Reply With Quote
Hope it's your brand 
