patternMinor
Drawing Fractals with MS Excel VBA
Viewed 0 times
fractalsexcelwithdrawingvba
Problem
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 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 lim Then y3 = lim 'check for drawing limits
If x3 > lim Then x3 = lim
If y3 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(
```
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 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 lim Then y3 = lim 'check for drawing limits
If x3 > lim Then x3 = lim
If y3 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(
Solution
Public
Why are all of these variables declared Public?
It seems unnecessary; if need be, pass values between subs. Public declarations should be
Integers
Integers - integers are obsolete. According to msdn VBA silently converts all integers to
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.
So now when I see
Option Explicit
You have several variables undeclared -
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
Or something similar. It looks like you can definitely shorten the code to an
Shader2
In
For your color:
Good idea using
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
Calling
You don't need to
Pattern
I saw this piece of code
And I thought, wait isn't there a quarterPi variable? Yes, there is. It's a constant. Perfect!
Sheets
Worksheets have a
Arrow code
I think I see a pretty big "arrow" in
Refactoring
On this
It's the perfect opportunity to use a
```
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) /
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 'counterIt 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 → indexSo 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
NextOr 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 subPrivate 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 = 0Good idea using
RGB instead of Color or ColorIndex. But, since color is stored as an integer, you can use it as a function insteadDim myColor As Long
myColor = GetColor(r, g, b)
...
.Cells(x,y).Color = myColorIt 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 Shader2You 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 / 4And I thought, wait isn't there a quarterPi variable? Yes, there is. It's a constant. Perfect!
Sheets
Worksheets("sheet1").Rows.RowHeight = 8Worksheets 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 codeIf 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 IfIt'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) /
Code Snippets
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 'counterlng → lineLength
Const pi as Double = 3.14159
Const quarterPi as Double = ..
cx → centerHorizontal
cy → centerVertical
cc → indexDim 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
NextPrivate 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 = 0Context
StackExchange Code Review Q#161471, answer score: 3
Revisions (0)
No revisions yet.