Dibujando fractales con MS Excel VBA -- vba campo con excel campo con fractals camp codereview Relacionados El problema

Drawing Fractals with MS Excel VBA

11

problema

Español

He hecho el código VBA de Excel que dibuja y llena un patrón fractal. Sé que hay algunas formas más de optimizar el código, solo contento de que funcione ahora mismo.

` ` 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   ``
Original en ingles

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 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 ``

2

Público

¿Por qué todas estas variables declaran 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   ``

Parece innecesario; Si es necesario, pasar valores entre subs. Las declaraciones públicas deben ser ` Const en general. `

Enteros

enteros - Los enteros son obsoletos . De acuerdo con msdn vba < em> en silencio convierte todos los enteros a ` long . `

Nombres de variables

Los nombres de tus variables no me dicen mucho sobre ellos. Veo que hay un montón de comentarios que los explican: es mucho más fácil nombrarlos de forma descriptiva y completa para evitar los comentarios.

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

Así que ahora cuando veo ` For cnt = 1 to lineLength ` Sé que estamos dibujando líneas.

Comentarios

Como dije, comentarios - "código Dígale cómo, los comentarios le dicen por qué ". El código debe hablar por sí mismo, si necesita un comentario, es posible que tenga que ser más claro. Si no, el comentario debe describirlo por qué está haciendo algo en lugar de cómo lo estás haciendo. Aquí hay una algunas razones para evitar comentarios todos juntos.

CÓDIGO DE PREPECCIÓN

Veo que está recibiendo ` ypt `, ` 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 0 ` ... ` 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 1 `. Si no desea hacer un ` 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 2 para estos, al menos colóquelos en una matriz para un acceso más fácil: `

` ` 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 3 ` `

o algo similar. Parece que definitivamente puede acortar el código a un ` 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 4 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 5 ` o incluso un ` 99887766555443316 ` en este escenario. O mejor aún, haga un ` 99887766555443317 ` que hace el cálculo y utilícelo para asignar valores.

En ` 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 8 VERO QUE LLAMAN EN 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 9 PERO NO VE Const0 definido en cualquier lugar. Const1 atraparía esto, pero en su lugar, es posible que desee usar argumentos en su SUB `

` ` Const2 ` `

para su color:

` ` Const3 ` `

buena idea usando ` Const4 en lugar de Const5 o long26 . Pero, dado que el color se almacena como un entero, puede usarlo como una función en lugar de `

` ` Const7 ` `

Se ve mucho más limpio separado así.

Tal vez sea de Copiar / Pegar, pero no está obligando a todos su código de su código. Es buena práctica para sangrar todo su código de esa manera ` Const8 se adhirará como obvio. Incluso las declaraciones variables. `

Llamar

` ` Const9 ` `

No necesita ` long0 ` Subs, está obsoleto. En su lugar, solo use ` long1 ` o en su caso, solo ` long2 `.

Patrón

Vi esta pieza de código

` ` long3  ``

y pensé, espera, ¿no hay una variable de cuartos de mariscos? Sí hay. Es una constante. ¡Perfecto!

Hojas

` ` long4 ` `

Las hojas de trabajo tienen un ` long55 Propiedad - Vista de propiedades ( F4 ) y el campo 998877766554433336 (el que se encuentra en la parte superior) se puede utilizar como el nombre de la hoja de trabajo. De esta manera, puede evitar long7 y, en cambio, solo use long8 . `

Código de flecha

Creo que veo a una flecha bastante grande "en ` long9 `. Es posible que desee intentarlo aplanar ese .

Refactorización

En este código lng → lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx → centerHorizontal cy → centerVertical cc → index 0

` ` lng → lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx → centerHorizontal cy → centerVertical cc → index 1  / pre>   Es la oportunidad perfecta para usar un  lng → lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx → centerHorizontal cy → centerVertical cc → index 2 .   o  , llame a una función -     lng → lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx → centerHorizontal cy → centerVertical cc → index 3     Números mágicos      con algo como este     lng → lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx → centerHorizontal cy → centerVertical cc → index 4     Llamaríamos a que un número mágico  y los números mágicos se definen mejor como constantes, de esa manera, si alguna vez necesita cambiarlo, puede cambiar la constante y no se preocupe por encontrarlo en el código.  Otro      Todo lo que se dice, creo que has escrito algo muy creativo aquí y te aplaudo. Muchas de estas "mejoras" son solo formas estándar de hacerlo, pero no las conocerías a menos que vinieras aquí para su revisión. Así que, bienvenido a la revisión del código :)   ``

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 xe2x86x92 lineLength Const pi as Double = 3.14159 Const quarterPi as Double = .. cx xe2x86x92 centerHorizontal cy xe2x86x92 centerVertical cc xe2x86x92 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 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 :)

9  Fractal Mandelbrot con MPI  ( Mandelbrot fractal with mpi )
No estoy muy familiarizado con MPI. He escrito este pequeño pedazo de código para dibujar el procesamiento del fractal de Mandelbrot cada fila de la imagen en...

1  Jugando el juego de caos  ( Playing the game of chaos )
Según Código ROSETTA : El juego del caos es un método para generar el atractor de un iterado. Sistema de función (IFS). Uno de los ejemplos más conocidos ...

3  Generador de imágenes de Mandelbrot con iteración paralela  ( Mandelbrot image generator with parallel iteration )
Actualmente estoy tratando de optimizar esta clase que tengo para la generación fractal. La ecuación está destinada a ser conectable; He usado z => z*z + c ...

8  Árbol fractal orientado a objetos  ( Object oriented fractal tree )
Hice un árbol fractal orientado a objetos en JavaScript utilizando la biblioteca P5, consta de tres archivos: fraternal tree.js sucursal.js flower.js ...

6  Dibujando un copo de nieve de Koch en Android  ( Drawing a koch snowflake in android )
Aquí está mi intento de dibujar Koch Snowflake . Mi estado inicial es una línea en lugar de un triángulo equilátero para que pueda ajustar el máximo detalle ...

2  Simulación física de agregados limitados por difusión  ( Physical simulation of diffusion limited aggregates )
El siguiente código genera agregados limitados de difusión en un Lattice cuadrado bidimensional. Algunos del Código se han omitido (por ejemplo, Soporte par...

8  Impresión de letras en orden como una pirámide  ( Printing letters in order like a pyramid )
Hay este HackerRank Pregunta , donde necesitamos un Rhombus de letras . En cuanto a mi opinión, se puede ver como un poco de fractal, o lógica similar. Bu...

3  Segundo intento en la aplicación Sierpinski Triangle  ( Second attempt at sierpinski triangle app )
Soy un programador Java tratando de aprender las formas de Swift. Hace unos días, publiqué el código para una aplicación muy simple que dibuja un triángulo de...

4  Generando Julia Set Fractal  ( Generating julia set fractal )
Soy un principiante total de Python y he estado probando mis habilidades recientemente. Encontré este desafío en particular y quería darle un tiro. Hice est...

4  Trazando el copo de nieve de Koch  ( Plotting the koch snowflake )
El copo de nieve de Koch es un fractal bien conocido. Comenzando con un triángulo equilátero, un triángulo equilátero más pequeño se coloca a la mitad de cada...