2-6-CG-6-sphere_circle_color

Excel  macro  sphere_circle_color

      Sub sphere_circle_color()

      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

      Dim Xnode As Integer

      Dim Ynode As Integer

      Pi = 3.14159265358979

      For i = 1 To 37

      aa = (i - 1) * 10# * Pi / 180#

      x(i) = 50#

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

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

      Next i

      x(37) = x(1)

      y(37) = y(1)

      z(37) = z(1)

      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

      icol = 5

      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

      icol = 0

      da = 0#

B11:  tt = ts - da

      icol = 0

B27:  tt = tt + da

      icol = icol + 1

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

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

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

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

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

       Xnode = xx(1) * dx + xg

       Ynode = yy(1) * dy + yg

       Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)

       For j = 2 To 37

      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)

       Xnode = xx(j) * dx + xg

       Ynode = yy(j) * dy + yg

       myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode

       Next j

       Set myShape = myBuilder.ConvertToShape

       With myShape

       .Fill.ForeColor.RGB = RGB(25 * 10, 0, (25 - icol) * 10) '

       .Line.ForeColor.RGB = RGB(25 * 10, 0, (25 - icol) * 10) '

       .Line.Weight = 1.5

       End With

      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