Sub ShowStars()
Randomize 'Генератор случайных чисел
StarWidth = 25 'Ширина звезды
StarHeight = 25 'Высота звезды


For i = 1 To 10 'Цикл = количество звезд
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) 'Заливка случайным цветом
Application.Wait Now + TimeValue("00:00:01") 'Ждем прорисовки для эффекта появления
DoEvents 'Даем обновиться данным
Next i


Application.Wait Now + TimeValue("00:00:02") 'Пауза перед тем как убирать звезды


Set myShapes = Worksheets(1).Shapes 'Все рисованные объекты. В нашем случае - звезды нарисованнные нами
For Each shp In myShapes 'перебираем в цикле все звезды
If Left(shp.Name, 9) = "AutoShape" Then 'Если это наши объекты, то
shp.Delete 'удаялем их
Application.Wait Now + TimeValue("00:00:01") 'Ждем для эффекта угасания
End If
Next
Worksheets(1).Shapes("Message").Visible = True
End Sub

Scio me nihil scire

<<Jojo®>>