A bit of fun - Draw a christmas tree

[JamesW]

Hey,

We did this years ago in Java for a bit of fun.

The challenge is to write some VBA to draw a christmas tree. The one that is written in the shortest code, and the most impressive, will win an e-cookie.

I will give it a go, but will fail miserably

Merry xmas.

 

[schielrn]

Here was my first attempt, while I was waiting for a report to run.

Sub drawTree()
For i = 1 To 10
    With Cells(i, i + 10)
        .Offset(1, -i * 2 + 1).Resize(1, i - 1 + 1).Interior.ColorIndex = 4
        .Offset(1, -i).Resize(1, i - 1 + 1).Interior.ColorIndex = 4
        .Offset(1, -i * 2 + 1).Resize(1, i - 1 + 1).Value = "*"
        .Offset(1, -i).Resize(1, i - 1 + 1).Value = "*"
        .Offset(1, -i * 2 + 1).Resize(1, i - 1 + 1).Font.ColorIndex = 3
        .Offset(1, -i).Resize(1, i - 1 + 1).Font.ColorIndex = 3
    End With
Next i
Cells(12, "I").Resize(3, 3).Interior.ColorIndex = 53
ActiveSheet.UsedRange.ColumnWidth = 1
End Sub

I went with a simplistic approach. And I know I could build the tree with one line instead of 2, but haven't looked at what i need to do yet, or looked at the mathematic equation for it.

 

[Jon von der Heyden]

I think that's quite an elegant solution Rob, and that tree looks good!

 

[Jon von der Heyden]

Create a new workbook and copy this to the first sheet:

Excel Workbook
	A	B
1	Y	X
2	0	0
3	0	1
4	-10	1
5	-4	2
6	-8	2
7	-3	3
8	-6	3
9	-2	4
10	-4	4
11	-1	5
12	-3	5
13	0	6
14	3	5
15	1	5
16	4	4
17	2	4
18	6	3
19	3	3
20	8	2
21	4	2
22	10	1
23	0	1
Tree

Excel 2010

Then, in a standard module:

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

Public Sub MakeXmasTree()
    Dim lngLeft As Long, lngWidth As Long
    Dim lngTop As Long, lngHeight As Long
    Dim chtTree As Chart
    Dim rngSource As Range
    Dim lngCounter As Long
    
    With Sheets(1)
        .Columns("E:W").ColumnWidth = 2
        With .Range("F3")
            lngLeft = .Left
            lngTop = .Top
            lngWidth = .Offset(, 17).Left - .Left
            lngHeight = .Offset(20).Top - .Top
        End With
        Set chtTree = .ChartObjects.Add(Left:=lngLeft, Width:=lngWidth, Top:=lngTop, Height:=lngHeight).Chart
        Set rngSource = .Range("A1:B23")
    End With
    
    With chtTree
        With .Axes(xlCategory)
            .Border.LineStyle = xlNone
            .TickLabelPosition = xlNone
            .HasMajorGridlines = False
        End With
        With .Axes(xlValue)
            .Border.LineStyle = xlNone
            .TickLabelPosition = xlNone
            .HasMajorGridlines = False
        End With
        .HasLegend = False
        .HasTitle = True
        With .ChartTitle
            .Text = "merry christmas"
            .Format.TextFrame2.TextRange.Font.Name = "Comic Sans MS"
        End With
        .ChartType = xlXYScatterSmoothNoMarkers
        .SetSourceData Source:=rngSource
        For lngCounter = 3 To 22 Step 2
            With .SeriesCollection(1).Points(lngCounter)
                .MarkerStyle = xlMarkerStyleCircle
                .MarkerSize = 10
            End With
        Next lngCounter
        With .SeriesCollection(1).Points(12)
            .MarkerStyle = xlMarkerStyleDiamond
            .MarkerSize = 15
        End With
    End With
    
    With Range("E2:W2,E3:E22,E23:W23,W3:W22")
        .Value = Chr(151)
        .Font.Name = "Wingdings 2"
        .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
        .Font.ColorIndex = 33
        For lngCounter = 1 To 3
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=RANDBETWEEN(1,3)=" & lngCounter)
                .Font.ColorIndex = 20 + lngCounter
            End With
        Next lngCounter
    End With
    
    Do
        Calculate
        Sleep 300
        DoEvents
    Loop
End Sub

Close the VBE and then run the macro (ALT+F11, choose 'MakeXmasTree' and hit Run)

To kill the macro, hit the ESCAPE key, or CTRL+Break!

 

[schielrn]

Very nice Jon! I was going to add flashing bulbs to my tree, but decided not to in my original version. I hope to get back to it here sometime today to reduce the code and have it only need one line per action.

 

[schielrn]

Ok I have expanded some and reduced the statements into one line:

Sub drawTree()
For i = 1 To 18
    With Cells(i, i + 10)
        If i < 4 Then
            .Offset(0, -i * 2 + 1).Resize(1, i * 2 - 1).Interior.ColorIndex = 6
            .RowHeight = 7.5
        ElseIf i < 6 Then
            .Offset(0, (i Mod 4) - i - 1).Resize(1, Abs(i * 5 - i ^ 2 - 1)).Interior.ColorIndex = 6
            .RowHeight = 7.5
        ElseIf i < 16 Then
            .Offset(0, (-i + 5) * 2 - 4).Resize(1, (i - 5) * 2 - 1).Interior.ColorIndex = 4
            .Offset(0, (-i + 5) * 2 - 4).Resize(1, (i - 5) * 2 - 1).Value = "*"
            .Offset(0, (-i + 5) * 2 - 4).Resize(1, (i - 5) * 2 - 1).Font.ColorIndex = 3
        Else
            .Offset(0, -i - 1).Resize(1, 3).Interior.ColorIndex = 53
        End If
    End With
Next i
ActiveSheet.UsedRange.ColumnWidth = 1
End Sub

 

[MrKowz]

Aww... jon's code blows up on Excel 2003. Can't set the LineStyle properties.

 

[Jon von der Heyden]

About time you upgrade Keith

 

[Sandeep Warrier]

Time to use PtrSafe again .... 64 Bit version !#$#$%@$#%

 

[JamesW]

Rubbish... I can't 'judge' Jon's code as I am using 2003 at work!