A whole forest inside Excel

Using fractals a tree or a set of trees can be drawn inside Excel. Something like this:

Option Explicit

Private Const PI As Double = 3.1416

Private Sub sForest()
    Dim nTree As Long
    Dim nTrees As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual

        With ActiveSheet
            .Shapes.SelectAll
            Selection.Delete
        End With
    End With

    nTrees = VBA.CLng(fRnd(1, 10))
    For nTree = 1 To nTrees
        Call sTree_Draw
    Next nTree

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Private Sub sTree_Draw()
    Dim R As Double
    Dim x As Double 'X position
    Dim y As Double 'Y position
    Dim d As Long
    Dim L As Double
    Dim dt As Double
    Dim Color As Long

    x = fRnd(50, 500)
    y = fRnd(50, 500)
    d = fRnd(5, 10)
    L = y / fRnd(5, 10)
    dt = fRnd(15, 35)
    Color = VBA.RGB(VBA.CByte(fRnd(0, 255)), VBA.CByte(fRnd(0, 255)), VBA.CByte(fRnd(0, 255)))

    Call sBranch_Draw(x, y, L, 0.8, 90, dt, 10, Color)
End Sub

Private Sub sBranch_Draw(ByVal x As Double, _
                         ByVal y As Double, _
                         ByVal L As Double, _
                         ByVal s As Double, _
                         ByVal t As Double, _
                         ByVal dt As Double, _
                         ByVal d As Long, _
                         ByVal Color As Long)
    Dim X1 As Double
    Dim Y1 As Double
    Dim oShp As Excel.Shape

    With ActiveSheet
        X1 = x + L * VBA.Cos(t * PI / 180)
        Y1 = y - L * VBA.Sin(t * PI / 180)
        Set oShp = .Shapes.AddLine(BeginX:=x, BeginY:=y, EndX:=X1, EndY:=Y1)
        With oShp
            With .Line
                '.Style = msoLineStyleMixed
                .ForeColor.RGB = Color
            End With
        End With<span 				data-mce-type="bookmark" 				id="mce_SELREST_start" 				data-mce-style="overflow:hidden;line-height:0" 				style="overflow:hidden;line-height:0" 			></span>
    End With

    If (d > 1) Then
        Call sBranch_Draw(X1, Y1, L * s, s, t + dt, dt, d - 1, Color)
        Call sBranch_Draw(X1, Y1, L * s, s, t - dt, dt, d - 1, Color)
    End If
End Sub

Private Function fRnd(ByVal Min As Double, _
                      ByVal Max As Double, _
                      Optional ByVal Seed As Double = 0) As Double
    If Seed = 0 Then
        fRnd = Min + ((Max - Min) * VBA.Rnd())
    Else
        fRnd = Min + ((Max - Min) * VBA.Rnd(Seed))
    End If
End Function
[/sourcecode]