Draw a Koch Snowflake with Microsoft PowerPoint (VBA)

Abstract

This article demonstrates how to draw a Koch snowflake, a simple yet beatiful fractal, with Microsoft PowerPoint using Visual Basic for Applications (VBA).

Objective

Draw the fractal for any shape (consisting of single lines) for a given depth (=number of iterations).

Setup

The fractal is a simple algorithm using a line, divide into three equal parts, replace the inner part with two legs of a isosceles triangle. The last leg (the inner part of the initial line) is simply omitted. As this procedure is then repeated over and over again the drawing becomes more and more detailed.

First steps

Single line, 5 iterations

Triangle line, 5 iterations

Square line, 5 iterations

Source Code

A helping VBA class was built before drawing the actual fractal. The class provides flip operations for PowerPoint line shape elements.

clsLine

Option Explicit

Public t As Long ' top

Public l As Long ' left

Public w As Double ' width

Public h As Double ' height

Public hf As Boolean ' horizontal flip

Public ol As Shape ' object line (shape)

Public Property Get length() As Double

length = Sqr(ol.Width ^ 2 + ol.Height ^ 2)

End Property

Public Property Let setLength(ByVal l As Double)

End Property

Public Function ps() As Point ' end point

Dim tp As Point

If Not ol.HorizontalFlip Then

tp.x = ol.Left

tp.Y = ol.Top + IIf(ol.VerticalFlip, ol.Height, 0)

Else

tp.x = ol.Left + ol.Width

tp.Y = ol.Top + IIf(ol.VerticalFlip, ol.Height, 0)

End If

ps = tp

End Function

Public Function pe() As Point ' end point

Dim tp As Point

If ol.HorizontalFlip Then

tp.x = ol.Left

tp.Y = ol.Top + IIf(ol.VerticalFlip, 0, ol.Height)

Else

tp.x = ol.Left + ol.Width

tp.Y = ol.Top + IIf(ol.VerticalFlip, 0, ol.Height)

End If

pe = tp

End Function

Public Function angle() As Double ' angle start-end

If ps.x = pe.x Then

angle = 0

Else

' compute cos

Dim cos As Double

cos = ol.Height / Me.length

angle = ARCCOS(cos)

End If

If ol.HorizontalFlip And ol.VerticalFlip Then

angle = 360 - angle

ElseIf ol.HorizontalFlip And Not ol.VerticalFlip Then

angle = 180 + angle

ElseIf Not ol.VerticalFlip And Not ol.HorizontalFlip Then

angle = 180 - angle

Else

End If

End Function

basKochSnowFlake

Option Explicit

Public Type Point

x As Double

Y As Double

End Type

Public Const Pi As Double = 3.14159265358979

Public Const Pi180 As Double = 0.0174532925199433

Function GM() As Double

GM = 0.55 '(Sqr(5) - 1) / 2

End Function

Function ARCSIN(ByVal dblSinus As Double) As Double

ARCSIN = Atn(dblSinus / Sqr(-dblSinus * dblSinus + 1)) / Pi180

End Function

Function ARCCOS(ByVal dblCosinus As Double) As Double

ARCCOS = (Atn(-dblCosinus / Sqr(-dblCosinus * dblCosinus + 1)) + 2 * Atn(1)) / Pi180

End Function

Function paintAngleFromPoint(ptStart As Point, ByVal angle As Double,

ByVal Radius As Double, Optional Color As Long) As Point

Dim SinL As Double

Dim CosL As Double

angle = angle * Pi180

SinL = Sin(angle) * Radius

CosL = cos(angle) * Radius

ActiveWindow.Selection.SlideRange.Shapes.AddLine(ptStart.x, ptStart.Y, ptStart.x + SinL, ptStart.Y - CosL).Select

Dim r As Long

Dim g As Long

Dim b As Long

Dim colorPalette As Variant

Dim lngColor As Long

colorPalette = Array(RGB(0, 104, 204), RGB(28, 142, 252), RGB(6, 133, 255), RGB(0, 78, 153), RGB(0, 61, 120))

'colorPalette = Array(RGB(69, 106, 168), RGB(153, 178, 221), RGB(104, 137, 194), RGB(45, 85, 153), RGB(24, 62, 126))

lngColor = colorPalette(RAND_INT(0, 4))

ActiveWindow.Selection.ShapeRange.Line.ForeColor.RGB = lngColor 'Color

ActiveWindow.Selection.ShapeRange.Line.Weight = 0.5 '1.5

paintAngleFromPoint.x = ptStart.x + SinL

paintAngleFromPoint.Y = ptStart.Y - CosL

End Function

Sub paintBaseShape(ByVal ol As clsLine)

Dim p As Point

p = ol.ps

Dim se As Double

Dim r As Double

se = ol.angle - 90

r = ol.length / 3

p = paintAngleFromPoint(p, se + 90, r)

p = paintAngleFromPoint(p, se + 30, r)

p = paintAngleFromPoint(p, se + 150, r)

p = paintAngleFromPoint(p, se + 90, r)

End Sub

Sub main()

Dim o As clsLine

Dim i As Long

Set o = New clsLine

Set o.ol = ActiveWindow.Selection.SlideRange.Shapes(1)

Dim c As New Collection

For i = 1 To ActiveWindow.Selection.SlideRange.Shapes.Count

c.Add ActiveWindow.Selection.SlideRange.Shapes(i).Name

Dim e As Variant

For Each e In c

Set o = New clsLine

Set o.ol = ActiveWindow.Selection.SlideRange.Shapes(e)

paintBaseShape o

ActiveWindow.Selection.SlideRange.Shapes(e).Delete

End Sub

Sub drawKochSnowFlake()

Dim n As Integer

Dim depth As Integer

depth = 5

For n = 1 To depth

Call main()

End Sub

Sub drawTriangle()

Dim p As Point

p.x = 100 : p.Y = 100

p = paintAngleFromPoint(p, 90, 200)

p = paintAngleFromPoint(p, 210, 200)

p = paintAngleFromPoint(p, 330, 200)

End Sub

Sub drawSquare()

Dim p As Point

p.x = 100 : p.Y = 100

p = paintAngleFromPoint(p, 90, 200)

p = paintAngleFromPoint(p, 180, 200)

p = paintAngleFromPoint(p, 270, 200)

p = paintAngleFromPoint(p, 360, 200)

End Sub

Sub drawAny()

Dim p As Point

Dim length As Integer

Dim i As Integer

p.x = 300 : p.Y = 300

Dim angle As Integer

angle = 90 ' <-- define this angle, e.g. 90° for a square

length = 100 ' <-- define this as line length

For i = 0 To (360 / angle)

p = paintAngleFromPoint(p, i * angle, length)

End Sub

Function RAND_INT(ByVal l As Long, ByVal u As Long, Optional recalc_trigger) As Long

Randomize

RAND_INT = Int((u - l + 1) * Rnd + l)

End Function

Abstract

Objective

Setup

First steps

Single line, 5 iterations

Triangle line, 5 iterations

Square line, 5 iterations

Source Code

clsLine

basKochSnowFlake

Links