惑星ぽいのを動かす。

どれかを突き詰めることに今は気持ちが向かず，ちょっと遊びで作ったものです。

私は理科の教員ですが，天体が大の苦手。幸い化学の教員なので，あまり迷惑はこうむってはいません。

ですが，いろいろとそれなりに目に映るものが作れそうになってきたので，少しはやってみようと思いました。

せっかくクラスモジュールを教えていただいているので，これはそれが活きる題材かと思い，適当に作ってみました。

細かいところは気にしていないので，お遊びであることをご容赦ください。

スライド１には，Sun,Mercury,Venus,Earth,Moon,Marsという図を用意します。　円で十分です。
グループ化するくらい凝る場合は，グループに名前を付けてください。パーツの名前ではありません。
円を用意するのが面倒な場合は，標準モジュールの該当部分のコードを削ればオッケーです。

半径は，今の長さを取得して利用するので，それっぽい距離をSunから離してあげてください。
Moonの場合はEarthとの距離が半径になります。

StopButtonという名前のボタンを用意してもらい，StopMacroを関連付けます。
このボタンのテキストを更新しているので地味に重要な部品です。

円運動というマクロを実行してみてください。

半径を取得するメソッドをMoveマクロに絡められなかったのは，力の無さによるものです。

コードはこちら

標準モジュール

Option Explicit
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private blnStop As Boolean

Sub 円運動()
ActivePresentation.SlideShowSettings.Run
blnStop = False

Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
Dim Sun As Shape: Set Sun = TSlide.Shapes("Sun")
Dim Mercury As Shape: Set Mercury = TSlide.Shapes("Mercury")
Dim Venus As Shape: Set Venus = TSlide.Shapes("Venus")
Dim Earth As Shape: Set Earth = TSlide.Shapes("Earth")
Dim Mars As Shape: Set Mars = TSlide.Shapes("Mars")

Dim Moon As Shape: Set Moon = TSlide.Shapes("Moon")
Dim Angle As Currency

Dim p As Parts: Set p = New Parts
Dim p2 As Parts: Set p2 = New Parts
Dim p3 As Parts: Set p3 = New Parts
Dim p4 As Parts: Set p4 = New Parts
Dim p5 As Parts: Set p5 = New Parts
Dim i As Long

Do
    Angle = -i * 3.14 / 180 * 10
    p.GetR Mercury, Sun
    p2.GetR Venus, Sun
    p3.GetR Earth, Sun
    p4.GetR Moon, Earth
    p5.GetR Mars, Sun
    
    p.Move Mercury, Sun, Angle * 4.15
    p2.Move Venus, Sun, Angle * 1.62
    p3.Move Earth, Sun, Angle
    p4.Move Moon, Earth, Angle * 10
    p5.Move Mars, Sun, Angle * 0.531
    
    TSlide.Shapes("StopButton").TextFrame.TextRange = "STOP"
    
    DoEvents
    If blnStop = True Then Exit Do
    Sleep 100
    i = i + 1
Loop

Application.SlideShowWindows(1).View.Exit

End Sub

Sub StopMacro()
    If blnStop = False Then blnStop = True
End Sub

Parts.cls

Option Explicit

Private pX As Currency
Private pY As Currency
Private pXCenter As Currency
Private pYCenter As Currency
Private pR As Currency


Public Sub GetR(pShp1 As Shape, pShpCenter As Shape)
    pXCenter = pShp1.Left + pShp1.Width / 2
    pYCenter = pShp1.Top + pShp1.Height / 2
    Dim pShpCXCenter As Currency
    Dim pShpCYCenter As Currency
    
    pShpCXCenter = pShpCenter.Left + pShpCenter.Width / 2
    pShpCYCenter = pShpCenter.Top + pShpCenter.Height / 2
     
     pR = Sqr((pXCenter - pShpCXCenter) ^ 2 + (pYCenter - pShpCYCenter) ^ 2)
End Sub

Public Sub Move(pShp1 As Shape, pShpCenter As Shape, pAngle As Currency)
    pX = pShp1.Left
    pY = pShp1.Top
    pXCenter = pShp1.Left + pShp1.Width / 2
    pYCenter = pShp1.Top + pShp1.Height / 2
    
    Dim pShpCXCenter As Currency
    Dim pShpCYCenter As Currency
    
    pShpCXCenter = pShpCenter.Left + pShpCenter.Width / 2
    pShpCYCenter = pShpCenter.Top + pShpCenter.Height / 2

    pX = pShpCXCenter + pR * Cos(pAngle) - pShp1.Width / 2
    pY = pShpCYCenter + pR * Sin(pAngle) - pShp1.Height / 2

    pShp1.Left = pX
    pShp1.Top = pY

End Sub

ここで見ると長めにも見えますがVBEditorに貼るととても短いです（ΦωΦ）

こんな感じになります。Moonはあんまり速すぎるとわけがわからないので，かなり周期がおかしいのはご容赦を

これは，作るのが特に楽しかったなぁ