A whole forest inside Excel

Using fractals a tree or a set of trees can be drawn inside Excel.

Something like this:

Forest

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]

Leave a Reply

Your email address will not be published. Required fields are marked *