Drawing Fractals with MS Excel VBA

Question

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.

Example

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
Sub Shader2()
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
 Next rad
 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
Call Shader2
End Sub

• cHao: I suppose "use something besides Excel and VBA" isn't the answer you want, is it. :)
• Shae: 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

Answer 1

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.

Comments

---

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.

Shader2

---

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)

For your color:

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
Call Shader2

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
 Select Case radius
 Case radius < (horizontalCenter / 6)
 Case radius < (horizontalCenter * 2)
 Case radius < (horizontalCenter * 3) / 6
 Case radius < (horizontalCenter * 4) / 6
 Case radius < (horizontalCenter * 5) / 6
 Case radius < (horizontalCenter)
 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 :)