2-4-CG-4-sphere-star

Excel macro    sphere_star()

      Sub sphere_star()

      Dim x(37) As Double

      Dim y(37) As Double

      Dim z(37) As Double

      Dim xx(37) As Double

      Dim yy(37) As Double

      Pi = 3.14159265358979

      For i = 1 To 13

      x(i) = 50#

      Next i

      y(1) = 0#

      z(1) = 1#

      y(2) = 0.25

      z(2) = 0.433

      y(3) = 0.866

      z(3) = 0.5

      y(4) = 0.5

      z(4) = 0#

      y(5) = 0.866

      z(5) = -0.5

      y(6) = 0.25

      z(6) = -0.5

      y(7) = 0#

      z(7) = -1#

      y(8) = -0.25

      z(8) = -0.5

      y(9) = -0.866

      z(9) = -0.5

      y(10) = -0.5

      z(10) = 0#

      y(11) = -0.866

      z(11) = 0.5

      y(12) = -0.25

      z(12) = 0.433

      y(13) = 0#

      z(13) = 1#

      For i = 1 To 13

      y(i) = y(i) * 3#

      z(i) = z(i) * 3#

      Next i

      Set RngStart = Worksheets("sheet1").Range("B30")

      xs = RngStart.Left

      ys = RngStart.Top

      Set RngEnd = Worksheets("sheet1").Range("P2")

      ye = RngEnd.Top

      xe = xs + (ys - ye)

      xmin = -80#

      xmax = 80#

      ymin = -80#

      ymax = 80#

      dx = (xe - xs) / (xmax - xmin)

      dy = (ye - ys) / (ymax - ymin)

      xg = -xmin * dx + xs

      yg = -ymin * dy + ys

      aaa = 30# * Pi / 180#

      bbb = 30# * Pi / 180#

      For i = 1 To 11

      bb = (i - 1) * 9# * Pi / 180#

      bc = (Sin(0.61547971) * Sin(bb)) / Cos(bb)

      bc = Atn(bc)

        aab = 2# * Pi * Cos(bb)

      enc = aab * 50#

      na = enc / 8#

      da = 2# * Pi / na

      bbc = Pi / 2# - 0.61547971

      If (i = 10) Then

      ts = -Pi / 4# - da

      te = Pi * 3# / 4#

      Else

         ts = -Pi / 4# - bc

         te = Pi * 3# / 4# + bc / 2#

      End If

      If (i = 11) Then

      GoTo B12

      Else

      End If

      aab = 2# * Pi * Cos(bb)

      enc = aab * 50#

      na = enc / 8#

      da = 2# * Pi / na

      bbc = Pi / 2# - 0.6154797

      If (bb < bbc) Then

      GoTo B11

      Else

      End If

      If (i = 10) Then

      GoTo B99:

      Else

        If (i = 9) Then

        ts = -Pi / 4# - da

        te = Pi * 3# / 4# + 3# * da

        Else

      ts = -Pi * 3# / 4# - da

      te = Pi * 5# / 4#

        End If

      End If

B99:

      If (i = 11) Then

      GoTo B12

      Else

      GoTo B11

      End If

B12:  ts = 0#

      te = -0.001

      da = 0#

B11:  tt = ts - da

B27:  tt = tt + da

      For j = 1 To 13

      x1 = xi(x(j), y(j), z(j), tt, bb)

      y1 = yj(x(j), y(j), bb)

      z1 = zk(x(j), y(j), z(j), tt, bb)

      xx(j) = xa(x1, y1, z1, aaa, bbb)

      yy(j) = yb(x1, y1, z1, aaa, bbb)

      xx(j) = xx(j) * dx + xg

      yy(j) = yy(j) * dy + yg

      Next j

      For j = 1 To 12

      x1 = xx(j)

      y1 = yy(j)

      x2 = xx(j + 1)

      y2 = yy(j + 1)

      ActiveSheet.Shapes.AddLine x1, y1, x2, y2

      Next j

      x1 = xx(13)

      y1 = yy(13)

      x2 = xx(1)

      y2 = yy(1)

      ActiveSheet.Shapes.AddLine x1, y1, x2, y2

      If (tt <= te) Then GoTo B27

      Next i

     End Sub

      Function xa(ax, ay, az, a, b)

      xa = -az * Cos(b) + ax * Cos(a)

      End Function

      Function yb(ax, ay, az, a, b)

      yb = -az * Sin(b) - ax * Sin(a) + ay

      End Function

      Function xi(ax, ay, az, a, b)

      xi = ax * Cos(a) * Cos(b) - ay * Cos(a) * Sin(b) - az * Sin(a)

      End Function

      Function yj(ax, ay, b)

      yj = ax * Sin(b) + ay * Cos(b)

      End Function

      Function zk(ax, ay, az, a, b)

      zk = ax * Sin(a) * Cos(b) - ay * Sin(a) * Sin(b) + az * Cos(a)

      End Function