Bit of fun.....

[Jamie2002]

I'm trying to create a KnightRider type bar that runs on a worksheet and just keeps looping but does'nt effect the use of the spreadsheet.

I've started with the following code which makes one box light red then one dark red, then the next one light red, previous one dark red...etc..

I'm only new to VBA though and you can't see this running it just shows as it would after all the code has run.

Although this is just a want it could be of use to add a certain amount of animation to a sheet.

Please help.

Dim i As Long, tot As Long
tot = 100



For i = 1 To tot
ActiveSheet.Shapes("Rectangle 1&quot.Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Next i

For i = 1 To tot
ActiveSheet.Shapes("Rectangle 2&quot.Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Next i

 

[LSTAN]

Hi

Try this

Dim i As Long, tot As Long
i = 0
tot = 100
Do
ActiveSheet.Shapes("Rectangle 1&quot.Select
With Selection.ShapeRange.Fill
.ForeColor.SchemeColor = 20
.Visible = msoTrue
.Solid
End With
ActiveSheet.Shapes("Rectangle 2&quot.Select
With Selection.ShapeRange.Fill
.ForeColor.SchemeColor = 20
.Visible = msoTrue
.Solid
End With
'
'
Application.Wait Now + TimeValue("00:00:01&quot
'
ActiveSheet.Shapes("Rectangle 1&quot.Select
With Selection.ShapeRange.Fill
.ForeColor.SchemeColor = 10
.Visible = msoTrue
.Solid
End With
ActiveSheet.Shapes("Rectangle 2&quot.Select
With Selection.ShapeRange.Fill
.ForeColor.SchemeColor = 10
.Visible = msoTrue
.Solid
End With
'
'
Application.Wait Now + TimeValue("00:00:01&quot
'
i = i + 1
Loop Until i = 100

Hope this is what you are looking for.

LSTAN

 

[SkipVought]

Hi,
Let me weigh in with a more compact approch. You can assign the color scheme value some other way...

    Dim i As Long, tot As Long, iColorScheme
    i = 0
    tot = 100
    For i = 0 To tot
        For Each Shape In ActiveSheet.Shapes
            Shape.Select
            iColorScheme = Int((i + 1) * Rnd)
            With Selection.ShapeRange.Fill
                .ForeColor.SchemeColor = iColorScheme
            End With
        Next
        Application.Wait Now + TimeValue("00:00:01")
    Next

Skip,
metzgsk@voughtaircraft.com

 

[SkipVought]

...that is assuming that you only had 2 shapes you wanted to glitz Skip,
metzgsk@voughtaircraft.com

 

[SkipVought]

...well, actually, I should have said...

assuming that you wanted ALL your shapes to glitz Skip,
metzgsk@voughtaircraft.com

 

[danomaniac]

Hey Jamie,
I played around with this a little, I think this is kind of the effect you're looking for - only it ties up the spreadsheet. Still, looks cool. Couldn't spend any more time on it.

Sub Kit()

Dim i, i2, iColor As Long
Dim count As Long
i = 0
i2 = 0
iColor = 0

' this section will draw 128 adjacent rectangles -
' make sure you only run this section of code the -
' first time, or you'll end up with tons of boxes.

Dim left, width As Long
left = 5
width = 3
Dim x As Integer

For x = 1 To 256
ActiveSheet.Shapes.AddShape msoShapeRectangle, left, 50, width, 20
left = left + width
Next x
' end of rectangle drawing section


count = 0
Do

For Each Shape In ActiveSheet.Shapes

If count > 512 Then count = 0
count = count + 8
iColor = Abs((count) - 256)
Shape.Fill.ForeColor.RGB = RGB(iColor, 0, 0)

Next
Application.Wait Now 'TimeValue("00:00:01&quot

Loop
End Sub

 

[danomaniac]

I meant it draws 256 boxes, not 128, but you can play with the values.

 

[SkipVought]

...and

you might just want to clean things up with...

For Each Shape In ActiveSheet.Shapes
   Shape.Delete
Next

Skip,
metzgsk@voughtaircraft.com