Embedded Files
f(r,θ、φ）の球座標をｇ（X,Y,Z)に変換
θとφを変えてプロット
Excel macro sphere_circle()
Sub sphere_circle()
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
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
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 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)
xx(j) = xx(j) * dx + xg
yy(j) = yy(j) * dy + yg
Next j
For j = 1 To 36
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(37)
y1 = yy(37)
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
Page updated
Google Sites
Report abuse