今回はExcelのオートシェイプで作成した、球体をグラフィカルに動かすツールのご紹介です。
ただ、動かすだけでは味気ないので、太陽系をイメージして楕円形に太陽の周りを、8個の惑星が動くように作成しました。
今回使用する球体の縮図は太陽の大きさと、冥王星(一番外側の星)の距離が、 大きすぎと離れすぎのため手を加えています。
公転の傾きは考慮していません。
また、このツールは独自に作成しただけで、計算方法等が必ずしも最適であり正しいとは限りません。
「ただ、集計するだけじゃなくて、こんなこともできるんだー！」くらいの参考に見て頂ければと思います。
今回のツールはVBAだけではハードルが高くExcelの関数やセルを活用しました。
1.ツールのサンプル動画
まずはサンプル動画です。
画面に収まるように縮図や速度は一部修正しています。
2.Excelで準備する事
Excelで準備する事は次のとおりです。
- 9個の球体を作成
- 各パラメーターの一覧を作成
- 開始ボタンを作成
順番にご説明します。
9個の球体を作成
オートシェイプで球体を作成する方法です。
挿入タブの図形を選択します。
図形の種類は「円/楕円」を選択します。
挿入した図形を右クリックして、図形の書式設定から「3-D書式」を選択します。
「幅」と「高さ」のptを変更する事で立体的な球体が作成できます。
現時点では図形の位置やサイズは適当で大丈夫です。(後ほど3-Dも含め微調整します。)
各パラメーターの一覧を作成
太陽を中心に残りの8個の球体の位置関係や大きさ、楕円の軌道等を設定するためのパラメーターとなります。
今回使用したパラメーターは次の通りです。
- 惑星名
- 位置関係(万km)
- 位置縮図(1/200)
- 直径(万km)
- 直径縮図(千km)
- 公転周期
- 1ループの加算
- ラジアン、x、y
- シェイプ名
- 裏/表設定
一覧にしたのが次の表です。
A~Gはネット情報や任意の縮図設定となります。
H～Jの「ラジアン」「x」「y」には数式が入っています。
H3には「=RADIANS(G3)」、I3には「=COS(H3)」、J3には「=SIN(H3)」です。
数式をオートフィルで10行目までコピーしています。
この数式で三角関数のサイン、コサインで座標を計算しています。
ズラッと数字が並んでいますが、一つ一つ見ると難しい事は特にありません。
実際の大きさと距離や、小さくした時の大きさと距離、三角関数だけです。
開始ボタンを作成
開始ボタンは必須ではありませんが、動かす際にVBEで都度実行が不便なため用意しました。
作成方法は球体と同じで、挿入タブの「図形」から「正方形/長方形」を選択して、開始とテキストを入力します。
図形を右クリックして「マクロの登録」をします。
後ほどこの登録したプロシージャにVBAを書きます。
3.VBAで準備する事
Excelの準備整いましたので、次はVBAで球体を動かすための各パーツを作成します。
作成する内容は大きく4つで、すべて標準モジュールに記載しています。
- 球体の位置、サイズの初期設定プロシージャ
- 球体の軌道と座標を計算して、指定するプロシージャ
- 各オートシェイプの前後関係を判定するプロシージャ
- 開始ボタンを押した時のプロシージャ
順番にコード付きでご説明します。(基本的にコード内のコメントに書いています。)
球体の位置、サイズの初期値設定
Option Explicit
Const SunPos As Long = 1200 '太陽の初期位置設定(この設定基軸に他の惑星の位置関係を設定する)
Const MoveSpeed As Long = 100 '1ループで惑星が移動する設定
Const x As Long = 100 '軌道のx軸
Const y As Long = 50 '軌道のy軸
Sub Reset()
Dim i As Long
'TOP、Left、高さ、幅、最背面設定
'太陽
With ActiveSheet.Shapes(Cells(2, 11))
.Top = SunPos / 2 'TOP位置はSunPosの1/2
.Left = SunPos
.Height = Cells(2, 5)
.Width = Cells(2, 5)
.ZOrder msoSendToBack '最背面指定
End With
'太陽以外の惑星
'TopはE列の太陽の直径縮図の半径と自身の半径マイナスを計上する
'LeftはE列の太陽の直径縮図の半径を計上する
For i = 3 To 10
With ActiveSheet.Shapes(Cells(i, 11))
.Top = SunPos / 2 + Cells(2, 5) / 2 - Cells(i, 5) / 2 'TOP位置はSunPosの1/2
.Left = SunPos + Cells(2, 5) + Cells(i, 3)
.Height = Cells(i, 5)
.Width = Cells(i, 5)
.ZOrder msoSendToBack '最背面指定
End With
Next i
End Subまず、「宣言セクション」部分に、太陽のExcel上の表示位置と惑星がループで移動する速度、(x、y)座標の設定をします。
初期設定では「MoveSpeed 」が動画用に100のため、かなり早い速度になっています。
「Sub Reset()」でまず、中心となる太陽の位置を設定します。
「.ZOrder msoSendToBack」で最背面に指定しています。
※ここで指定する意味はあまりありませんが、順番を整理するためにしています。
次に残りの8個の惑星分も同様に位置とサイズを指定しています。
この時に注意するのが、ExcelのオートシェイプのTOPとLEFT位置は中心から計算するのではなく、一番上と左から計算する必要があります。
そのため、太陽の半径と惑星の半径を計算に計上しています。
「.Top = SunPos / 2 + Cells(2, 5) / 2 – Cells(i, 5) / 2」で「太陽の(TOP位置+太陽の半径)-惑星の半径」で太陽の中心と同じ一直線上に並ぶようにTOP位置を計算しています。
「.Left = SunPos + Cells(2, 5) + Cells(i, 3)」も同様に太陽の半径を計上して惑星の距離を指定しています。
最後に「.ZOrder msoSendToBack」で最背面に指定する事で、太陽から順に遠くなるほど背面に設定されている状態になります。
この時に作成した球体のサイズがパラメーターにより変更されて、3-Dが若干崩れる可能性がありますので、微調整を行ってください。
球体の軌道と座標を計算して指定する
Sub Simulation()
Dim i As Long
Dim InitialPos As Collection
'8個の惑星の軌道計算と移動
Set InitialPos = New Collection
'初期位置取得
For i = 3 To 10
InitialPos.Add ActiveSheet.Shapes(Cells(i, 11)).Left
Cells(i, 7) = -MoveSpeed / Cells(i, 6)
Next i
'無限ループ
Do While True
DoEvents
DoEvents
'1ループ内に8個の球体すべてループ
For i = 3 To 10
With ActiveSheet.Shapes(Cells(i, 11))
'太陽の初期位置+太陽の半径-該当惑星の半径+座標y
.Top = SunPos / 2 + Cells(2, 5) / 2 - Cells(i, 5) / 2 + (y * (Cells(i, 10))) 'TOP位置はSunPosの1/2
'太陽の位置+太陽の半径+該当惑星の初期位置-太陽の位置-太陽の半径*座標x/100
.Left = SunPos + Cells(2, 5) / 2 + ((InitialPos(i - 2) - SunPos - Cells(2, 5) / 2) * Cells(i, 9) * x / 100)
Call ShapePos_Set 'シェイプの前後関係
End With
Cells(i, 7) = Cells(i, 7) + (-MoveSpeed / Cells(i, 6)) '次のx,y座標設定
Next i
Loop
End Subまず最初に、円の軌道を計算するために必要になるため各惑星の初期位置と、1ループで進む速度を「速度/公転周期」で算出して取得します。
マイナスにしているのは反時計回りにするためです。
次に「Do While True~Loop」で無限ループ状態にして、その中に8つの惑星の位置計算と移動を、ループで指定しています。
計算方法はTOPが「太陽の初期位置+太陽の半径-該当惑星の半径+座標y」、LEFTが「太陽の位置+太陽の半径+該当惑星の初期位置-太陽の位置-太陽の半径*座標x/100」です。
各オートシェイプの前後関係を判定する
Sub ShapePos_Set()
Dim i As Long
'太陽の中心値を基準として、該当惑星の位置から表裏フラグ設定
'裏表から各惑星の前後位置を設定
For i = 3 To 10
With ActiveSheet.Shapes(Cells(i, 11))
If SunPos / 2 + Cells(2, 5) / 2 - Cells(i, 5) / 2 < .Top + Cells(i, 5) / 2 Then
Cells(i, 12) = "表"
Else
Cells(i, 12) = "裏"
End If
End With
Next i
ActiveSheet.Shapes(Cells(2, 11)).ZOrder msoBringToFront
For i = 3 To 10
If Cells(i, 12) = "表" Then
ActiveSheet.Shapes(Cells(i, 11)).ZOrder msoBringToFront
End If
Next i
ActiveSheet.Shapes(Cells(2, 11)).ZOrder msoSendToBack
For i = 3 To 10
If Cells(i, 12) = "裏" Then
ActiveSheet.Shapes(Cells(i, 11)).ZOrder msoSendToBack
End If
Next i
End Sub単純に軌道を移動させるだけでは、すべて太陽の裏に隠れてしまうため、裏に回る軌道か、表を回る軌道か判定して、「.ZOrder msoBringToFront」で最前面、「.ZOrder msoSendToBack」で最背面に指定しています。
判定の計算方法は「SunPos / 2 + Cells(2, 5) / 2 – Cells(i, 5) / 2 < .Top + Cells(i, 5) / 2」で算出しており、「太陽位置+太陽の半径-惑星の半径」<「TOP位置+惑星の半径」で太陽の中心と惑星の中心の位置関係を求めています。
1回のループごとに再設定を行います。
表と裏をそれぞれIF文で分岐して2回のループで処理を行い、太陽を最初に設定してから順番に内側から最前面、最背面と指定します。
これにより、設定を「太陽→次に近い惑星→次に近い惑星」と設定することで、先に設定した惑星が前(もしくは後ろ)に指定されるようになるので、順番が最終的に逆になります。
開始ボタンを押した時
こちらは単純に各プロシージャを呼び出しているだけです。
開始を押すと動き出します。
Sub Start_Click()
'開始ボタン
Call Reset
Call Simulation
End Sub最後の装飾
雰囲気を出すためにセルの背景色を暗くしています。
4.サンプルファイルのダウンロード
ディスプレの解像度が変わった場合の動作検証も簡単には行っていますが、変に動いたら便宜変更お願いします。
5.まとめとツール作りで大事なこと
このツールが何の役に立つの？と言われたら、役に立ちません。
でもいつも計算にばかり使われているExcelでこんな事が出来るのは楽しくないですか？
また、コードをよく見てもらえるとわかりますが、実はFor~NextのループとIf文ばかりでほとんど「難しい」、「特殊」なコードは使われていません。
これくらいのコードとあとはアイデアと発想で何でも作れます。
最後に、ツール作る時の大事な事として
「最初から完成形を作ろうとしない」ことです。
今回のツールを作る時も、最初は1個の球体を楕円形に動かすコードを書いてみました。
動いたら、2個同時に動かすコードを書いてみて、軌道をずらす工夫を組み込みました。
ここまで出来たら、あとは同じロジックで何個でも球体を増やせます。
まずは最も簡単な動くツールを作る事が大事です。
