Fun code

[GeorgeB]

Here's some code that will pop up multiple stars on a worksheet at one second intervals and then remove them.

Public Sub ShowStars()
Randomize
StarWidth = 50
StarHeight = 50
For i = 1 To 100
TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
Delay 0.01
DoEvents
Next i

Application.Wait Now + TimeValue("00:00:01")

Set myShapes = Worksheets(1).Shapes
For Each shp In myShapes
If Left(shp.Name, 9) = "AutoShape" Then
shp.Delete
Delay 0.01
End If
Next

End Sub


Public Sub Delay(rTime As Single)
'delay rTime seconds (min=.01, max=300)
Dim oldTime As Variant
'safety net
If rTime< 0.01 Or rTime > 300 Then rTime = 1
oldTime = Timer
Do
DoEvents
Loop Until Timer - oldTime > rTime

End Sub



_________________
George
This message was edited by GeorgeB on 2002-04-02 21:24

 

[Anne Troy]

Hmmm...I replied once already but it didn't stick.

I'll try again.

Brian: I think you're probably trying to put in *Public Sub ShowStars()* when all you need to put is *ShowStars* and the Public Sub and () will be added automatically when you hit OK. Procedures must have one-word names.

 

[Brian from Maui]

Dreamboat,

Got it to run.



Thanks again!

Brian
This message was edited by Brian from Maui on 2002-04-07 00:57

 

[verluc]

On 2002-04-02 21:23, GeorgeB wrote:
OK here goes
Open a fresh workbook, right click on the sheet tab, select “View code”
This will put you into the VBE (Visual Basic Editor) At the top of the
Screen click on “Insert” select “Procedure” name them the same as my post
and paste in the code. Do this twice, once for each procedure.
Good luck

You write : open a fresh workbook.
How can I do it with a existant workbook.
I have a workbook and I want this macro to run automatickly when I open it.
Can you give me this procedure?
Many thanks.

 

[Paul B]

Put the ShowStars Marco in a module, then put this in the thisworkbook code

Private Sub Workbook_Open()
Call ShowStars
End Sub

 

[verluc]

On 2002-04-07 14:35, Paul B wrote:
Put the ShowStars Marco in a module, then put this in the thisworkbook code

Private Sub Workbook_Open()
Call ShowStars
End Sub

I have done what you wrote.But when I open the workbook,then I receive a message error on the line :Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
I can not see what this can be wrong.
Can you help me?
Thanks

 

[verluc]

On 2002-04-07 14:52, verluc wrote:

On 2002-04-07 14:35, Paul B wrote:
Put the ShowStars Marco in a module, then put this in the thisworkbook code

Private Sub Workbook_Open()
Call ShowStars
End Sub

I have done what you wrote.But when I open the workbook,then I receive a message error on the line :Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
I can not see what this can be wrong.
Can you help me?
Thanks

 

[verluc]

On 2002-04-07 23:53, verluc wrote:

On 2002-04-07 14:52, verluc wrote:

On 2002-04-07 14:35, Paul B wrote:
Put the ShowStars Marco in a module, then put this in the thisworkbook code

Private Sub Workbook_Open()
Call ShowStars
End Sub

I have done what you wrote.But when I open the workbook,then I receive a message error on the line :Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
I can not see what this can be wrong.
Can you help me?
Thanks

Who can give me the solution about this error?
Many thanks.

 

[Colo]

Hi verluc. I only a few tampered with the code. Please try.<Pre>
Public Sub ShowStars()
Dim StarWidth As Integer, StarHeight As Integer, i As Integer
Dim shp As Shape, TopPos As Double, LeftPos As Double
Dim NewStar As Shape
Randomize
StarWidth = 50: StarHeight = 50
For i = 1 To 100
TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
Set NewStar = ActiveSheet.Shapes.AddShape _
(91, LeftPos, TopPos, StarWidth, StarHeight)
NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
Delay 0.01
DoEvents
Next
Application.Wait Now + TimeValue("00:00:01")
For Each shp In ActiveSheet.Shapes
If shp.Type = 1 Then shp.Delete: Delay 0.01
Next
End Sub</Pre>
This message was edited by Colo on 2002-04-09 18:30