2-5-CG-5-sphere_object

Excel macro    sphere_object()

      Sub sphere_object()

      Dim x(39) As Double

      Dim y(39) As Double

      Dim z(39) As Double

      Dim xx(99) As Double

      Dim yy(39) As Double

      Pi = 3.14159265358979

      For i = 1 To 39

      x(i) = 50#

      Next i

      y(1) = 0#

      z(1) = 0.8

      y(2) = 0.2

      z(2) = 0.8

      y(3) = 0.2

      z(3) = 1#

      y(4) = 0.4

      z(4) = 1.1

      y(5) = 0.5

      z(5) = 0.95

      y(6) = 0.4

      z(6) = 0.75

      y(7) = 0.5

      z(7) = 0.6

      y(8) = 0.43

      z(8) = 0.5

      y(9) = 0.2

      z(9) = 0.38

      y(10) = 0.1

      z(10) = 0.2

      y(11) = 0.43

      z(11) = 0.1

      y(12) = 0.48

      z(12) = 0.05

      y(13) = 1#

      z(13) = 0.05

      y(14) = 1#

      z(14) = -0.05

      y(15) = 0.48

      z(15) = -0.05

      y(16) = 0.35

      z(16) = -0.1

      y(17) = 0.2

      z(17) = -0.3

      y(18) = 0.5

      z(18) = -0.9

      y(19) = 0.3

      z(19) = -0.9

      y(20) = 0#

      z(20) = -0.4

      y(21) = -0.3

      z(21) = -0.9

      y(22) = -0.5

      z(22) = -0.9

      y(23) = -0.2

      z(23) = -0.3

      y(24) = -0.35

      z(24) = -0.1

      y(25) = -0.48

      z(25) = -0.05

      y(26) = -1#

      z(26) = -0.05

      y(27) = -1#

      z(27) = 0.05

      y(28) = -0.48

      z(28) = 0.05

      y(29) = -0.48

      z(29) = 0.1

      y(30) = -0.1

      z(30) = 0.2

      y(31) = -0.2

      z(31) = 0.35

      y(32) = -0.43

      z(32) = 0.5

      y(33) = -0.5

      z(33) = 0.6

      y(34) = -0.4

      z(34) = 0.25

      y(35) = -0.5

      z(35) = 0.95

      y(36) = -0.4

      z(36) = 1.1

      y(37) = -0.2

      z(37) = 1#

      y(38) = -0.2

      z(38) = 0.8

      y(39) = 0#

      z(39) = 0.8

      For i = 1 To 39

      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 39

      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 38

      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(39)

      y1 = yy(39)

      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