Drawing Fractals with MS Excel VBA

I've made Excel VBA code that draws and fills a fractal pattern. I know there's a few more ways to optimize the code, just glad it works right now.

Dim lng As Integer 'length of drawn lines
Dim pi As Double 'pi
Dim qpi As Double 'quarter pi
Dim rnpt() As Double 'list of avaialble points to draw from
Dim cx As Integer 'center of drawing
Dim cy As Integer
Dim stpt() As Double 'placeholder for new endpoints drawn
Dim fspt() As Double 'temp endpoints
Dim cc As Integer 'counter

'draws a 2-d bidirectional dividing fractal given a set of coordinates created in pattern()
Sub draw()

For cnt = 1 To lng 'draws each set of lines

t = Timer 'timer loop to prevent system freezes and lets run in background
Do While Timer < t + 0.01
DoEvents
Loop

For cnt2 = 0 To UBound(rnpt(), 2) - 1 'loops through all available points

y = rnpt(0, cnt2) 'virtual y
x = rnpt(1, cnt2) 'virtual x
Z = rnpt(2, cnt2) 'z = direction

ypa = y + WorksheetFunction.Round(Cos(Z + qpi), 0) * cnt 'extrapolates future pixels of division and checks all nearby points for collision as each pixel is drawn
xpa = x + WorksheetFunction.Round(Sin(Z + qpi), 0) * cnt

ypt1 = y + WorksheetFunction.Round(Cos(Z + qpi), 0) * (cnt + 1)
xpt1 = x + WorksheetFunction.Round(Sin(Z + qpi), 0) * (cnt + 1)

ypt2 = ypa + WorksheetFunction.Round(Cos(Z + qpi + qpi), 0)
xpt2 = xpa + WorksheetFunction.Round(Sin(Z + qpi + qpi), 0)
ypt3 = ypa + WorksheetFunction.Round(Cos(Z + qpi - qpi), 0)
xpt3 = xpa + WorksheetFunction.Round(Sin(Z + qpi - qpi), 0)
ypt4 = ypa + WorksheetFunction.Round(Cos(Z + qpi - qpi * 2), 0)
xpt4 = xpa + WorksheetFunction.Round(Sin(Z + qpi - qpi * 2), 0)
ypt5 = ypa + WorksheetFunction.Round(Cos(Z + qpi + qpi * 2), 0)
xpt5 = xpa + WorksheetFunction.Round(Sin(Z + qpi + qpi * 2), 0)

ypb = y + WorksheetFunction.Round(Cos(Z - qpi), 0) * cnt 'second division line being drawn
xpb = x + WorksheetFunction.Round(Sin(Z - qpi), 0) * cnt

ypt6 = y + WorksheetFunction.Round(Cos(Z - qpi), 0) * (cnt + 1)
xpt6 = x + WorksheetFunction.Round(Sin(Z - qpi), 0) * (cnt + 1)

ypt7 = ypb + WorksheetFunction.Round(Cos(Z - qpi + qpi), 0)
xpt7 = xpb + WorksheetFunction.Round(Sin(Z - qpi + qpi), 0)
ypt8 = ypb + WorksheetFunction.Round(Cos(Z - qpi - qpi), 0)
xpt8 = xpb + WorksheetFunction.Round(Sin(Z - qpi - qpi), 0)
ypt9 = ypb + WorksheetFunction.Round(Cos(Z - qpi - qpi * 2), 0)
xpt9 = xpb + WorksheetFunction.Round(Sin(Z - qpi - qpi * 2), 0)
ypt10 = ypb + WorksheetFunction.Round(Cos(Z - qpi + qpi * 2), 0)
xpt10 = xpb + WorksheetFunction.Round(Sin(Z - qpi + qpi * 2), 0)

'checks for missing pixels
If Not Worksheets("sheet1").Cells(cy - ypa, cx + xpa).Interior.Color = 255 And Not fspt(2, cnt2 * 2) = 1 Then
f1 = 1
End If

'checks for collision
If Worksheets("sheet1").Cells(cy - ypa, cx + xpa).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt1, cx + xpt1).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt2, cx + xpt2).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt3, cx + xpt3).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt4, cx + xpt4).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt5, cx + xpt5).Interior.Color = 255 Then
fspt(2, cnt2 * 2) = 1
ElseIf Not fspt(2, cnt2 * 2) = 1 Then
Worksheets("sheet1").Cells(cy - ypa, cx + xpa).Interior.Color = 255
fspt(0, cnt2 * 2) = ypa
fspt(1, cnt2 * 2) = xpa
fspt(3, cnt2 * 2) = Z + qpi
End If

'fills missing pixels
If f1 = 1 Then
Worksheets("sheet1").Cells(cy - ypa, cx + xpa).Interior.Color = 255
End If

'checks for dead pixels in line 2
If Not Worksheets("sheet1").Cells(cy - ypb, cx + xpb).Interior.Color = 255 And Not fspt(2, cnt2 * 2 + 1) = 1 Then
f2 = 1
End If

'checks for line 2 collision
If Worksheets("sheet1").Cells(cy - ypb, cx + xpb).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt6, cx + xpt6).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt7, cx + xpt7).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt8, cx + xpt8).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt9, cx + xpt9).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Worksheets("sheet1").Cells(cy - ypt10, cx + xpt10).Interior.Color = 255 Then
fspt(2, cnt2 * 2 + 1) = 1
ElseIf Not fspt(2, cnt2 * 2 + 1) = 1 Then
Worksheets("sheet1").Cells(cy - ypb, cx + xpb).Interior.Color = 255
fspt(0, cnt2 * 2 + 1) = ypb
fspt(1, cnt2 * 2 + 1) = xpb
fspt(3, cnt2 * 2 + 1) = Z - qpi
End If

'fills missing pixels line 2
If f2 = 1 Then
Worksheets("sheet1").Cells(cy - ypb, cx + xpb).Interior.Color = 255
End If

'variable reset
f1 = 0
f2 = 0

Next cnt2

Next cnt

For cc = 0 To UBound(rnpt(), 2) - 1 'adds new endpoints if no collision occured

If Not fspt(2, cc * 2) = 1 Then
ReDim Preserve stpt(3, UBound(stpt, 2) + 1)
stpt(0, UBound(stpt, 2) - 1) = fspt(0, cc * 2)
stpt(1, UBound(stpt, 2) - 1) = fspt(1, cc * 2)
stpt(2, UBound(stpt, 2) - 1) = fspt(3, cc * 2)
End If

If Not fspt(2, cc * 2 + 1) = 1 Then
ReDim Preserve stpt(3, UBound(stpt, 2) + 1)
stpt(0, UBound(stpt, 2) - 1) = fspt(0, cc * 2 + 1)
stpt(1, UBound(stpt, 2) - 1) = fspt(1, cc * 2 + 1)
stpt(2, UBound(stpt, 2) - 1) = fspt(3, cc * 2 + 1)
End If
Next cc
End Sub

'fills pattern shapes based on radial distance from center

Dim r As Integer 'color variables
Dim g As Integer
Dim b As Integer

Dim var As Double 'variable to adjust color
Dim rte As Integer 'square root holder for distance

Dim x As Integer 'current pixel
Dim y As Integer

Dim x2 As Integer
Dim y2 As Integer

Dim c3 As Integer

Dim y3 As Integer
Dim x3 As Integer

Dim t As Integer

Dim box() As Integer 'fill area array

Dim c As Double

Dim lim As Integer 'limit of drawing

ReDim box(2, 1) 'set initial dimensions

lim = 1499 'set limit

r = 255 'set initial color

var = (255 / (cx / 6)) 'set rate of color change by drawing diminsions

For c = 0 To 2 * pi Step pi / 180 / 2 'radial loop direction by half degrees

r = 255
g = 0
b = 0

For c2 = 1 To cx - 1 'loop distance from center to drawing dimensions

ReDim box(2, 1) 'reset fill area

x = Math.Round(Sin(c) * c2, 0) 'set current pixel by current direction and distance
y = Math.Round(Cos(c) * c2, 0)

c3 = 1

t3 = 0

If Worksheets("sheet1").Cells(cy - y, cx + x).Interior.Color = 0 Then 'check for next empty pixel

x2 = Sin(c) * (c2 + c3) 'check next pixel
y2 = Cos(c) * (c2 + c3)

box(0, 0) = y 'set starting pixel to array
box(1, 0) = x

Do While Worksheets("sheet1").Cells(cy - y2, cx + x2).Interior.Color = 0 'check while next available pixel is empty to find shape area distance from center
x2 = Sin(c) * (c2 + c3) 'get next coordinate
y2 = Cos(c) * (c2 + c3)

c3 = c3 + 1 'counter for shape bisection

rte = Math.Round(Sqr(x2 ^ 2 + y2 ^ 2), 0) 'set current distance

If rte > lim Or c3 > 80 Then 'end loop at drawing limit
Exit For
End If
Loop

rte = Math.Round(Sqr(x2 ^ 2 + y2 ^ 2), 0) 'set final distance

tim = Timer 'loop to prevent freezing and allow background processes
Do While Timer < tim + 0.01
DoEvents
Loop

If rte < cx / 6 Then 'set color based on distance from center
g = var * rte
ElseIf rte < 2 * cx / 6 Then
r = 255 - var * (rte - cx / 6)
ElseIf rte < 3 * cx / 6 Then
b = var * (rte - 2 * cx / 6)
ElseIf rte < 4 * cx / 6 Then
g = 255 - var * (rte - 3 * cx / 6)
ElseIf rte < 5 * cx / 6 Then
r = var * (rte - 4 * cx / 6)
ElseIf rte < cx Then
b = 255 - var * (rte - 5 * cx / 6)
End If

x3 = x 'save current coordinate
y3 = y

Worksheets("sheet1").Cells(cy - y, cx + x).Interior.Color = RGB(r, g, b) 'set current coordinate

Do While t3 = 0 'fill shape area loop

For cnt = 1 To UBound(box(), 2) 'for all available pixels

t2 = 0 'reset pixel direction counter

y3 = box(0, UBound(box(), 2) - cnt) 'set next available pixel
x3 = box(1, UBound(box(), 2) - cnt)

If y3 > lim Then y3 = lim 'check for drawing limits
If x3 > lim Then x3 = lim
If y3 < -lim Then y3 = -lim
If x3 < -lim Then x3 = -lim

For rad = 0 To 3 * pi / 2 Step pi / 2 'loop through four possible directions

'check for current color and pattern color
If Not Worksheets("sheet1").Cells(cy - y3 - Cos(rad), cx + x3 + Sin(rad)).Interior.Color = 255 And Not Worksheets("sheet1").Cells(cy - y3 - Cos(rad), cx + x3 + Sin(rad)).Interior.Color = RGB(r, g, b) And Not x3 = lim And Not y3 = lim And Not x3 = -lim And Not y3 = -lim Then
Worksheets("sheet1").Cells(cy - y3 - Cos(rad), cx + x3 + Sin(rad)).Interior.Color = RGB(r, g, b) 'set current color

t2 = t2 + 1 'check available pixel direction 1-4

'if first pixel, overwrite previous pixel, else add new pixel
If t2 = 1 Then
box(0, UBound(box(), 2) - cnt) = y3 + Cos(rad)
box(1, UBound(box(), 2) - cnt) = x3 + Sin(rad)
Else:
box(0, UBound(box(), 2) - 1) = y3 + Cos(rad)
box(1, UBound(box(), 2) - 1) = x3 + Sin(rad)
End If

ReDim Preserve box(2, UBound(box(), 2) + 1) 'add space for next loop
End If

If UBound(box(), 2) - 1 > 0 Or t3 = 1 Then 'check if none remain or only one direction
If t2 = 0 Then 'check for remaining directions
If Not cnt = 1 Then 'remove dead fill pixels

For del = UBound(box(), 2) - cnt To UBound(box(), 2) - 2

box(0, del) = box(0, del + 1)
box(1, del) = box(1, del + 1)

Next del

ReDim Preserve box(2, UBound(box(), 2) - 1)

Else:
ReDim Preserve box(2, UBound(box(), 2) - 1)
End If

Exit For 'check next pixel
Else:
ReDim Preserve box(2, UBound(box(), 2) - 1) 'remove dead fill pixel
End If
Else:
t3 = 1 'loop break if no pixels remain
Exit For
End If

Next cnt
Loop
c2 = c3 + c2 - 1 'move loop count to next shape

End If
Next c2
Next c

End Sub

Sub pattern()

Worksheets("sheet1").Rows.RowHeight = 8 'set excel cell area to minimum pixel dimensions and reset cell color
Worksheets("sheet1").Columns.ColumnWidth = 1
Worksheets("sheet1").Rows.Interior.Color = 0

pi = WorksheetFunction.pi 'set pi value
qpi = pi / 4 'quarter pi

cx = 2000 'sets drawing center
cy = cx
lng = 10 'sets line length drawn

ReDim rnpt(3, 2) 'creates starting point array with coordinates and direction
ReDim fspt(0, 0)

rnpt(0, 0) = 0 'adds starting points to array
rnpt(1, 0) = 0
rnpt(2, 0) = pi / 4

rnpt(0, 1) = 0
rnpt(1, 1) = 0
rnpt(2, 1) = 5 * pi / 4

stpt = rnpt 'saves points

For c1 = 1 To 180 'number of repetitions to run

rnpt = stpt 'saves new endpoints

ReDim fspt(4, UBound(rnpt, 2) * 2) 'adds space for possible new endpoints

c3 = UBound(rnpt, 2) - 1 'placeholder for total number of endpoints

ReDim stpt(3, 0) 'resets endpoint placeholder

Call draw 'draws next set

Next c1

End Sub

• I suppose "use something besides Excel and VBA" isn't the answer you want, is it. :)
– cHao
Apr 22, 2017 at 2:22
• Lol, nah I'm able to use Excel at work, so it's easy for me to mess around with. I've made animations and so on entirely through excel
– Shae
Apr 22, 2017 at 16:40

Public

Why are all of these variables declared Public?

Dim lng As Integer 'length of drawn lines
Dim pi As Double 'pi
Dim qpi As Double 'quarter pi
Dim rnpt() As Double 'list of avaialble points to draw from
Dim cx As Integer 'center of drawing
Dim cy As Integer
Dim stpt() As Double 'placeholder for new endpoints drawn
Dim fspt() As Double 'temp endpoints
Dim cc As Integer 'counter


It seems unnecessary; if need be, pass values between subs. Public declarations should be Const in general.

Integers

Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.

Variable Names

Your variable names aren't telling me very much about them. I see there's a bunch of comments explaining them - it's much easier to name them descriptively and completely avoid comments.

lng → lineLength
Const pi as Double = 3.14159
Const quarterPi as Double = ..
cx → centerHorizontal
cy → centerVertical
cc → index


So now when I see For cnt = 1 to lineLength I know we're drawing lines.

Option Explicit

You have several variables undeclared - cnt and t for instance. It's best practice to always declare your variables and give them a type. You can have Option Explicit on automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

As I said, Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

Repeating Code

I see you're getting ypt, ypt2 ... ypt10. If you don't want to make a Class for these, at least put them in an array for easier access -

        Dim yPoints As Variant
ReDim yPoints(1 To 10)
For Index = 1 To 10
If i Mod 2 = 0 Then
yPoints(Index) = Round(Cos(Z + qpi), 0) * counter
Else
yPoints(Index) = Round(Sin(Z + qpi), 0) * counter
End If
Next


Or something similar. It looks like you can definitely shorten the code to an if loop or even a select case in this scenario. Or better yet, make a Function that does the calculation and use it to assign values.

In Sub Shader2() I see you calling on c2 but I don't see c2 defined anywhere. Option Explicit would catch this, but instead you might want to use arguments in your sub

Private Sub Shader(ByVal firstPoint as Double, ByVal secondPoint as Double, etc)


Dim r As Integer 'color variables
Dim g As Integer
Dim b As Integer
r = 255
g = 0
b = 0


Good idea using RGB instead of Color or ColorIndex. But, since color is stored as an integer, you can use it as a function instead

Dim myColor As Long
myColor = GetColor(r, g, b)
...
.Cells(x,y).Color = myColor


It looks a lot cleaner separated like that.

Spacing

Maybe it's from copy/paste, but you aren't indenting all of your code.It's good practice to indent all of your code that way Labels will stick out as obvious. Even the variable declarations.

Calling

Call draw 'draws next set
Next c1


You don't need to Call subs, it's obsolete. Instead just use Sub argument, argument or in your case, just Shader2.

Pattern

I saw this piece of code

rnpt(2, 0) = pi / 4


And I thought, wait isn't there a quarterPi variable? Yes, there is. It's a constant. Perfect!

Sheets

Worksheets("sheet1").Rows.RowHeight = 8


Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.

Arrow code

I think I see a pretty big "arrow" in Shader2. You might want to try to flatten that.

Refactoring

On this If code

        If rte < cx / 6 Then 'set color based on distance from center
g = var * rte
ElseIf rte < 2 * cx / 6 Then
r = 255 - var * (rte - cx / 6)
ElseIf rte < 3 * cx / 6 Then
b = var * (rte - 2 * cx / 6)
ElseIf rte < 4 * cx / 6 Then
g = 255 - var * (rte - 3 * cx / 6)
ElseIf rte < 5 * cx / 6 Then
r = var * (rte - 4 * cx / 6)
ElseIf rte < cx Then
b = 255 - var * (rte - 5 * cx / 6)
End If


It's the perfect opportunity to use a Select Case. Or, call a function -

g = ColorBasedOnDistance(radius, horizontalCenter)

Private Function ColorBasedOnDistance(ByVal radius As Long, ByVal horizontalCenter As Long) As Double
Case radius < (horizontalCenter / 6)
Case radius < (horizontalCenter * 2)
Case radius < (horizontalCenter * 3) / 6
Case radius < (horizontalCenter * 4) / 6
Case radius < (horizontalCenter * 5) / 6
Case Else
ColorBasedOnDistance = 0
End Select
End Function


Magic Numbers

With something like this

Worksheets("sheet1").Rows.RowHeight = 8


We would call that a magic number and magic numbers are best defined as constants, that way if you ever need to change it, you can just change the constant and not worry about finding it in the code.

Other

All that being said, I think you've written something very creative here and I applaud you. A lot of these "improvements" are just standard ways of doing it, but you wouldn't know them unless you came here for review. So, welcome to Code Review :)