円の内側で円を転がす ~もう少し情報を整理~
前回は、円の内側で小さな円が転がっている感を出すために、点を一つ
追加した。仮に、動点Pとでも名付けよう。更にこれをもっと滑らかに
動かすために、表の更新は一旦計算した値を配列に格納し、丸ごと張り
直すことで更新してみた。
infoment.hatenablog.com
今回も、前回の続きから。
動点Pの動きとして、くるくる回って同じ位置に戻るまでを描きたい。
そのためには、何周回るかなどを予め計算し、配列の大きさを決めて
おく必要がある。
ラベル行数
X座標、Y座標など、その列に入る値が何であるかを示す行が必要だ。
これは、一行あればよい。
大きな円の描画に必要な行数
滑らかな円を描くためには、円周上にある程度の点が必要だ。例えば4点では、
正方形を少し歪めたような形となって、とても円と呼ぶことは出来ない。
色々試してみたが、36点もあれば充分だろう。
大きな円は、分割数をとするならば、行必要だ。
なぜなら始点と終点を重ねないと、円が閉じないからだ。
小さな円の描画に必要な行数
これも大きな円の行数と同じ。この範囲を次々と更新することで、円が動いて
見えるようになる。
動点Pの行数
文字通り「点」なので、一行あればよい。
動点Pの軌跡に必要な行数
折角なので、動点Pの軌跡を描いてみよう。
大きな円の半径:
小さな円の半径:
とするとき、その円周の始めと終わりが重なる長さは、両者の最小公倍数である。
ExcelではLCM関数で求まる。従って小さな円の周回数は、
以下の式で求めることができる。
以上のことから、奇跡を描くための行数は以下のとおり。
※半径がの約数であるならば、がどんな数でも1周だけ回る。
※半径が素数であるならば、必ず周だけ回る。
行数の合計
今迄の行数を合計すると、以下のとおり。
一覧表にすると、このようになる。
マクロの改修
以上を踏まえて、修正したマクロがこちら。
Sub ぐるぐる() Cells(1, 1).Resize(Rows.Count - 1, 5).Clear Dim π As Double π = WorksheetFunction.Pi Dim r(1 To 3) As Long ' 大きな円の半径。 r(1) = 61 ' 小さな円の半径。 r(2) = 12 ' 小さな円の中心からのオフセット量。 r(3) = 10 ' ※r(1)とr(2)の最小公倍数÷r(1) ← 小さな円を何周回すか。 ' RoundNumberの略。 Dim rn As Long rn = WorksheetFunction.Lcm(r(1), r(2)) / r(1) ' 大きな円の中心座標。 Dim ox1 As Double Dim oy1 As Double ox1 = 0: oy1 = 0 ' 円周の分割数(Division Count) Dim dc As Double dc = 54 ' 大きい円と小さい円を分割する角度(rad)。 Dim dθ(1 To 2) As Double dθ(1) = 2 * π / dc dθ(2) = -r(1) / r(2) * dθ(1) ' 全描画に必要なグラフの行数。 ' ※大きな円の描画に必要な点 dc+1 ←始点と終点を重ねないと円が閉じない。 ' ※小さな円の描画に必要な点と動点Pの軌跡描画に必要な点の数は等しい。 Dim iMax As Long iMax = (dc + 1) * 2 + (dc * rn + 1) + 1 Dim myChart As ChartObject Set myChart = ActiveSheet.ChartObjects(1) myChart.Chart.SetSourceData Source:=Cells(1, 1).Resize(iMax + 1, 5) ' 各座標を格納するための配列。 ' 一次元を0始まりにするのは、ラベル名を格納するため。 Dim arr() As Variant ReDim arr(iMax, 1 To 5) arr(0, 1) = "X" arr(0, 2) = "Y1" arr(0, 3) = "Y2" arr(0, 4) = "Y3" arr(0, 5) = "Y4" ' 大きい円の座標。 Dim x1() As Double: ReDim x1(1 To dc + 1) Dim y1() As Double: ReDim y1(1 To dc + 1) ' 小さい円の座標。 Dim x2() As Double: ReDim x2(1 To dc * rn + 1) Dim y2() As Double: ReDim y2(1 To dc * rn + 1) ' 小さい円の中心。 Dim ox2() As Double: ReDim ox2(1 To dc * rn + 1) Dim oy2() As Double: ReDim oy2(1 To dc * rn + 1) ' 小さい円の中心からr(3)オフセットしたポイント。 Dim x3() As Double: ReDim x3(1 To dc * rn + 1) Dim y3() As Double: ReDim y3(1 To dc * rn + 1) Dim i As Long Dim j As Long Dim k As Long ' 大きな円の描画。 For i = 1 To dc + 1 x1(i) = r(1) * Cos(dθ(1) * (i - 1)) y1(i) = r(1) * Sin(dθ(1) * (i - 1)) arr(i, 1) = x1(i) arr(i, 2) = y1(i) Next ' 続けて描画するため、iの最終値を保存。 Dim LastIndex As Long LastIndex = i For i = 1 To dc * rn + 1 ' 小さな円の中心。 ox2(i) = r(1) * Cos(dθ(1) * (i - 1)) * (r(1) - r(2)) / r(1) oy2(i) = r(1) * Sin(dθ(1) * (i - 1)) * (r(1) - r(2)) / r(1) Application.Wait [Now() + "00:00:00.03"] DoEvents ' 小さい円を描画。 For j = 1 To dc + 1 x2(i) = ox2(i) + r(2) * Cos(dθ(1) * (j - 1)) y2(i) = oy2(i) + r(2) * Sin(dθ(1) * (j - 1)) arr(LastIndex + j - 1, 1) = x2(i) arr(LastIndex + j - 1, 3) = y2(i) Next ' 中心からオフセットしたポイント。 x3(i) = ox2(i) + r(3) * Cos(dθ(2) * (i - 1)) y3(i) = oy2(i) + r(3) * Sin(dθ(2) * (i - 1)) arr(LastIndex + j - 1, 1) = x3(i) arr(LastIndex + j - 1, 4) = y3(i) arr(LastIndex + j + k, 1) = x3(i) arr(LastIndex + j + k, 5) = y3(i) k = k + 1 Cells(1, 1).Resize(iMax, 5) = arr Next End Sub
実際に動かした結果がこちら。
ようやく、形になってきた。
次回に続きます。
参考まで。