|
Question : Merry Christmas to you all.
|
|
Now this is a little challenge for the festive season.
As you know I don't go with any of the pc nonsense of not saying Merry Christmas. Even though I'm a total non-believer I still celebrate Christmas with my family. It's a time of thinking of others and of being hospitable to family and their partners. So here's my challenge. The points go to the best offering which unusually I will let you all decide which is best.
What would be fun to have is a VBA routine that draws, colours (that's colors for some of you!) and illuminates in any way you choose, an Excel Christmas Tree.
You only have 24 hours to do it so I'll close this tomorrow - one way or another!
|
|
|
Answer : Merry Christmas to you all.
|
|
Here is the result of my wasted time:
Public Enum tColorIndex
mxlAutomaticColor = 0
mxlNoColor = -4142
mxlBlack = 1
mxlDarkRed = 9
mxlRed = 3
mxlPink = 7
mxlRose = 38
mxlBrown = 53
mxlOrange = 46
mxlLightOrange = 45
mxlGold = 44
mxlTan = 40
mxlOliveGreen = 52
mxlDarkYellow = 12
mxlLime = 43
mxlYellow = 6
mxlLightYellow = 36
mxlDarkGreen = 51
mxlGreen = 10
mxlSeaGreen = 50
mxlBrightGreen = 4
mxlLightGreen = 35
mxlDarkTeal = 49
mxlTeal = 14
mxlAqua = 42
mxlTurquoise = 8
mxlLightTurquoise = 34
mxlDarkBlue = 11
mxlBlue = 5
mxlLightBlue = 41
mxlSkyBlue = 33
mxlPaleBlue = 37
mxlIndigo = 55
mxlBlueGray = 47
mxlViolet = 13
mxlPlum = 54
mxlLavender = 39
mxlGray80 = 56
mxlGray50 = 16
mxlGray40 = 48
mxlGray25 = 15
mxlWhite = 2
End Enum
Public Sub PatrickKevinTree()
Dim Shape As Shape
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = False
End With
For Each Shape In ActiveSheet.Shapes
Shape.Delete
Next Shape
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0.75, 0.75, 2492.25, 500).Name = "Background"
With ActiveSheet.Shapes("Background").DrawingObject.ShapeRange.Fill
.ForeColor.SchemeColor = 56
.BackColor.SchemeColor = 48
.TwoColorGradient msoGradientHorizontal, 1
End With
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 304#, 51#)
.AddNodes msoSegmentLine, msoEditingAuto, 229.5, 123.5
.AddNodes msoSegmentLine, msoEditingAuto, 275.25, 123.5
.AddNodes msoSegmentLine, msoEditingAuto, 221.25, 191.75
.AddNodes msoSegmentLine, msoEditingAuto, 260.25, 191#
.AddNodes msoSegmentLine, msoEditingAuto, 202.5, 269.75
.AddNodes msoSegmentLine, msoEditingAuto, 243.75, 270.5
.AddNodes msoSegmentLine, msoEditingAuto, 187.5, 358.25
.AddNodes msoSegmentLine, msoEditingAuto, 441.75, 356#
.AddNodes msoSegmentLine, msoEditingAuto, 389.25, 275.75
.AddNodes msoSegmentLine, msoEditingAuto, 436.5, 275.75
.AddNodes msoSegmentLine, msoEditingAuto, 359.25, 190.25
.AddNodes msoSegmentLine, msoEditingAuto, 395.25, 191#
.AddNodes msoSegmentLine, msoEditingAuto, 336#, 122.75
.AddNodes msoSegmentLine, msoEditingAuto, 384.75, 123.5
.AddNodes msoSegmentLine, msoEditingAuto, 304#, 51#
.ConvertToShape.Name = "Tree"
End With
With ActiveSheet.Shapes("Tree").DrawingObject.ShapeRange
.Fill.ForeColor.SchemeColor = 17
.Line.Visible = msoFalse
End With
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 295.5, 357.5, 27.75, 81#).Name = "Trunk"
With ActiveSheet.Shapes("Trunk").DrawingObject.ShapeRange
.Fill.ForeColor.SchemeColor = 60
.Line.Visible = msoFalse
End With
With ActiveSheet.Shapes
.AddShape msoShape5pointStar, 271.5, 152.75, 18.75, 16.5
.AddShape msoShape5pointStar, 329.25, 199.25, 17.25, 15#
.AddShape msoShape5pointStar, 251.25, 243.5, 18#, 15.75
.AddShape msoShape5pointStar, 312#, 266.75, 19.5, 16.5
.AddShape msoShape5pointStar, 240.75, 323#, 14.25, 13.5
.AddShape msoShape5pointStar, 315#, 320#, 16.5, 15#
.AddShape msoShape5pointStar, 366#, 305.75, 16.5, 16.5
.AddShape msoShape5pointStar, 261#, 281#, 18#, 16.5
.AddShape msoShape5pointStar, 349.5, 239#, 19.5, 15.75
.AddShape msoShape5pointStar, 277.5, 214.25, 15.75, 15#
.AddShape msoShape5pointStar, 357.75, 166.25, 15.75, 13.5
.AddShape msoShape5pointStar, 313.5, 150.5, 18#, 15#
.AddShape msoShape5pointStar, 276.75, 103.25, 23.25, 18#
.AddShape msoShape5pointStar, 326.25, 99.5, 14.25, 12#
.AddShape msoShape5pointStar, 307.5, 234.5, 15#, 13.5
.AddShape msoShape5pointStar, 388.5, 249.5, 16.5, 13.5
.AddShape msoShape5pointStar, 354.75, 278.75, 15#, 15.75
.AddShape msoShape5pointStar, 293.25, 302#, 15.75, 13.5
.AddShape msoShape5pointStar, 270.75, 334.25, 18#, 12.75
.AddShape msoShape5pointStar, 357#, 336.5, 14.25, 14.25
.AddShape msoShape5pointStar, 243.75, 218.75, 16.5, 12.75
.AddShape msoShape5pointStar, 294#, 180.5, 15.75, 17.25
.AddShape msoShape5pointStar, 249#, 170#, 13.5, 11.25
.AddShape msoShape5pointStar, 201#, 341.75, 13.5, 12.75
.AddShape msoShape5pointStar, 402#, 332.75, 12#, 12#
.AddShape msoShape5pointStar, 231.75, 246.5, 12#, 12.75
.AddShape msoShape5pointStar, 306.75, 127.25, 24.75, 18.75
.AddShape msoShape5pointStar, 254.25, 107#, 9.75, 10.5
.AddShape msoShape5pointStar, 363#, 219.5, 12.75, 12#
.AddShape msoShape5pointStar, 292.5, 78.75, 14.25, 13.5
.AddShape msoShapeOval, 235.5, 302.25, 9#, 8.25
.AddShape msoShapeOval, 267.75, 314.25, 9#, 6#
.AddShape msoShapeOval, 336#, 303.75, 9#, 8.25
.AddShape msoShapeOval, 288#, 258#, 11.25, 11.25
.AddShape msoShapeOval, 332.25, 255#, 7.5, 7.5
.AddShape msoShapeOval, 310.5, 213#, 6#, 6#
.AddShape msoShapeOval, 275.25, 195.75, 8.25, 8.25
.AddShape msoShapeOval, 322.5, 183.75, 6#, 6#
.AddShape msoShapeOval, 378.75, 333.75, 7.5, 7.5
.AddShape msoShapeOval, 338.25, 339.75, 6#, 6#
.AddShape msoShapeOval, 300.75, 341.25, 6.75, 6.75
.AddShape msoShapeOval, 219.75, 332.25, 9#, 9#
.AddShape msoShapeOval, 258.75, 267.75, 6#, 6#
.AddShape msoShapeOval, 328.5, 229.5, 8.25, 8.25
.AddShape msoShapeOval, 340.5, 170.25, 6.75, 6.75
.AddShape msoShapeOval, 339#, 138.75, 7.5, 7.5
.AddShape msoShapeOval, 292.5, 136.5, 6#, 6#
.AddShape msoShapeOval, 317.25, 87.75, 6#, 6#
.AddShape msoShapeOval, 271.5, 92.25, 6#, 6#
.AddShape msoShapeOval, 353.25, 106.5, 6#, 6#
.AddShape msoShapeOval, 252.75, 156.75, 8.25, 8.25
.AddShape msoShapeOval, 374.25, 265.5, 6#, 6#
.AddShape msoShapeOval, 362.25, 206.25, 6.75, 6.75
.AddShape msoShapeOval, 218.25, 255.75, 6#, 6#
.AddShape(msoShape4pointStar, 285.25, 10.5, 38.25, 42.75).Name = "Star"
End With
With ActiveSheet.Shapes("Star").DrawingObject.ShapeRange
.Line.Visible = msoFalse
End With
For Each Shape In ActiveSheet.Shapes
If Shape.AutoShapeType = msoShape5pointStar Then
Shape.DrawingObject.ShapeRange.Line.Visible = msoFalse
End If
If Shape.AutoShapeType = msoShapeOval Then
Shape.DrawingObject.ShapeRange.Line.Visible = msoFalse
End If
Next Shape
Application.OnTime Now + 1 / 24 / 60 / 60, "Twinkle"
End Sub
Private Sub Twinkle()
Dim Shape As Shape
Dim Ovals As New Collection
Dim Stars As New Collection
Dim Index As Long
For Each Shape In ActiveSheet.Shapes
If Shape.AutoShapeType = msoShape5pointStar Then
Stars.Add Shape
End If
If Shape.AutoShapeType = msoShapeOval Then
Ovals.Add Shape
End If
Next Shape
For Index = 1 To 5
Ovals(Int(Rnd() * Ovals.Count + 1)).DrawingObject.ShapeRange.Fill.ForeColor.SchemeColor _
= Choose(Int(Rnd() * 7 + 1), mxlRed, mxlPink, mxlOrange, mxlGold, mxlYellow, mxlGreen, mxlBrightGreen)
Next Index
For Each Shape In Stars
Shape.Visible = IIf(Rnd() > 0.9, False, True)
Next Shape
Application.OnTime Now + 1 / 24 / 60 / 60, "Twinkle"
End Sub
Kevin
|
|
|
|
|
