11
\$\begingroup\$

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
\$\endgroup\$
  • 3
    \$\begingroup\$ I suppose "use something besides Excel and VBA" isn't the answer you want, is it. :) \$\endgroup\$ – cHao Apr 22 '17 at 2:22
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ – Shae Apr 22 '17 at 16:40
2
\$\begingroup\$

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 :)

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.