Random flashing shapes

Question

I'm trying to create an effect on a slide where if a button is clicked my shapes randomly and independently change from blue to yellow and back to blue and then stop with one of the shapes color in yellow (appearing that this is the selected shape).  This is for a game where the shapes would have the names of students and give the appearance that it is randomly selecting a student's name.  I imagine I will need some type of timer and random loop, but don't know where to begin.  Any help would be greatly appreciated.

Mike

Answer 1

Put a DoEvents statement inside the loop.

In 2010 the screen refresh lines should not be needed.

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub WhereSheStopsNobodyKnows()

' Only works in slideshow mode.

'

    Dim sld As Slide

    Dim shpRng As ShapeRange

    Dim shp As Shape

    Dim lnMin As Long, lnMax As Long, i As Long, lnRand As Long, lnPrev As Long

    Dim ssw As SlideShowWindow

    'Random = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin

    lnMin = 1

    lnMax = 4

     'Check we are in slideshow mode:

    On Error Resume Next

    Set ssw = ActivePresentation.SlideShowWindow

    On Error GoTo 0

    If ssw Is Nothing Then

        Exit Sub

    Else

        Set sld = ssw.View.Slide

    End If

    Set shpRng = sld.Shapes.Range(Array("Rectangle 1", "Rectangle 2", "Rectangle 3", "Rectangle 4"))

    For i = 1 To 30

        Do

            Randomize

            lnRand = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin 'get rand num.

        Loop While lnRand = lnPrev 'make sure rand num is different from previous rand num

        lnPrev = lnRand

        Sleep 100 '0.1s delay

        shpRng.Fill.ForeColor.RGB = RGB(0, 0, 255) 'set all shapes to blue

        sld.Shapes("Rectangle " & lnRand).Fill.ForeColor.RGB = RGB(255, 255, 0) 'set a random shape to yellow

        DoEvents

'         'Refresh the slide: (Not needed in 2010??)

        ssw.View.GotoSlide (sld.SlideIndex)

        Set shp = sld.Shapes.AddLine(0, 0, 0, 1)

        shp.Delete

    Next i

End Sub

Answer 2

2007 has great trouble redrawing the screen (it's a bug) s if Rich is using 2010 he will not see what you see in 2007. It will be very difficult to get5 this to work in 2007 (but Rich likes a challenge)

Guilty as charged!  I only tested it in ppt2013....

This works for me in ppt2007:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub WhereSheStopsNobodyKnows()

' Only works in slideshow mode.

'

    Dim sld As Slide

    Dim shpRng As ShapeRange

    Dim shp As Shape

    Dim lnMin As Long, lnMax As Long, i As Long, lnRand As Long, lnPrev As Long

    Dim ssw As SlideShowWindow

  'Random = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin

    lnMin = 1

    lnMax = 4

     'Check we are in slideshow mode:

    On Error Resume Next

    Set ssw = ActivePresentation.SlideShowWindow

    On Error GoTo 0

    If ssw Is Nothing Then

        Exit Sub

    Else

        Set sld = ssw.View.Slide

    End If

    Set shpRng = sld.Shapes.Range(Array("Rectangle 1", "Rectangle 2", "Rectangle 3", "Rectangle 4"))

    For i = 1 To 30

        Do

            Randomize

            lnRand = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin 'get rand num.

        Loop While lnRand = lnPrev 'make sure rand num is different from previous rand num

        lnPrev = lnRand

        Sleep 100 '0.1s delay

        shpRng.Fill.ForeColor.RGB = RGB(0, 0, 255) 'set all shapes to blue

        sld.Shapes("Rectangle " & lnRand).Fill.ForeColor.RGB = RGB(255, 255, 0) 'set a random shape to yellow

     'Refresh the slide:

ssw.View.GotoSlide (sld.SlideIndex)

Set shp = sld.Shapes.AddLine(0, 0, 0, 1)

shp.Delete

    Next i

End Sub

I found that for 2007, both GotoSlide and adding-then-deleting-a-shape is required to get the slideshow window to refresh mid-macro.

Cheers

Rich

Answer 3

After reviewing your code, I don't think that it's the problem.  I added a message box into the loop and the numbers do randomly change, but the color of the shape does not.  Could it be with the slide re-drawing or refreshing?  Not sure if I've used the correct syntax.

Answer 4

Thanks for responding Rich.  We're headed in the right direction, but only one shape changes colors randomly each time I run the macro.  I'd like to have the effect where each shape would change colors randomly during the running of the macro until it's finished with the loop or timer and then we have one left yellow.

What do you suggest?  I'll keep playing with the code, perhaps I'll figure it out.

Mike

Answer 5

Hi,

Try this:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub WhereSheStopsNobodyKnows()

' Only works in slideshow mode.

'

    Dim sld As Slide

    Dim shpRng As ShapeRange

    Dim lnMin As Long, lnMax As Long, i As Long, lnRand As Long, lnPrev As Long

    Dim ssw As SlideShowWindow

    'Random = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin

    lnMin = 1

    lnMax = 4

     'Check we are in slideshow mode:

    On Error Resume Next

    Set ssw = ActivePresentation.SlideShowWindow

    On Error GoTo 0

    If ssw Is Nothing Then

        Exit Sub

    Else

        Set sld = ssw.View.Slide

    End If

    Set shpRng = sld.Shapes.Range(Array("Rectangle 1", "Rectangle 2", "Rectangle 3", "Rectangle 4"))

    For i = 1 To 30

        Do

            lnRand = Int((lnMax - (lnMin - 1)) * Rnd) + lnMin 'get rand num.

        Loop While lnRand = lnPrev 'make sure rand num is different from previous rand num

        Sleep 100 '0.1s delay

        shpRng.Fill.ForeColor.RGB = RGB(0, 0, 255) 'set all shapes to blue

        sld.Shapes("Rectangle " & lnRand).Fill.ForeColor.RGB = RGB(255, 255, 0) 'set a random shape to yellow

        ssw.View.GotoSlide (sld.SlideIndex)

        lnPrev = lnRand

    Next i

End Sub

Cheers

Rich