# A bit of fun - Draw a christmas tree



## JamesW (Dec 20, 2010)

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 (Dec 20, 2010)

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 (Dec 21, 2010)

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


----------



## Jon von der Heyden (Dec 21, 2010)

Create a new workbook and copy this to the first sheet:Excel WorkbookAB1YX2003014-1015-426-827-338-639-2410-4411-1512-35130614351515164417241863193320822142221012301Tree*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 (Dec 21, 2010)

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 (Dec 21, 2010)

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 (Dec 21, 2010)

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


----------



## Jon von der Heyden (Dec 22, 2010)

About time you upgrade Keith


----------



## Sandeep Warrier (Dec 22, 2010)

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


----------



## JamesW (Dec 22, 2010)

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


----------



## Jon von der Heyden (Dec 22, 2010)

sandeep.warrier said:


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



You can take the entire do loop bit out and just hold down F9 to perform continuous calculate, and you will still get the same animation.

Otherwise you can run virtual PC and install a 32bit version.


----------



## Sandeep Warrier (Dec 22, 2010)

Got it to work....

I have the 64-bit version at work... and can't install much software


----------

