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
vote

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.

Ejemplo

  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.

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 
        
   
   

Lista de respuestas

2
 
vote

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.

Opción explícita

Usted tiene varias variables sindeclared - cnt y t por ejemplo. Es la mejor práctica para declarar siempre sus variables y darles un tipo . Puede tener Option Explicit encendido automáticamente al ir a las herramientas - & gt; Opciones en la opción VBE y comprobar la opción Requerir Declaración de variables . De esta manera, si tiene alguna variable no definida, el compilador le informará.

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.

SHADER2


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í.

Espaciado


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.

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

 
 

Relacionados problema

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




© 2022 respuesta.top Reservados todos los derechos. Centro de preguntas y respuestas reservados todos los derechos