図形の座標を提供するShpClsを育ててみる。 - インストールレスプログラミング( ´ー`)

chemiphys.hateblo.jp
前の記事で思ったクラスの一つ目，物体の座標を提供するクラスを作ってみました。
f:id:chemiphys:20170121021328p:plain
Shpcls.cls (ちょっと更新)

Option Explicit

Private pShp As Shape

Public Sub SetShp(図形 As Shape)
    Set pShp = 図形
End Sub

Property Get X() As Currency
    X = pShp.Left + pShp.Width / 2
End Property
Property Let X(X座標 As Currency)
    pShp.Left = X座標 - pShp.Width / 2
End Property

Property Get Y() As Currency
    Y = pShp.Top + pShp.Height / 2
End Property
Property Let Y(Y座標 As Currency)
    pShp.Top = Y座標 - pShp.Height / 2
End Property

Property Get Left() As Currency
    Left = pShp.Left
End Property
Property Let Left(pLeft As Currency)
    pShp.Left = pLeft
End Property

Property Get Right() As Currency
    Right = pShp.Left + pShp.Width
End Property
Property Let Right(pRight As Currency)
    pShp.Left = pRight - pShp.Width
End Property

Property Get Top() As Currency
    Top = pShp.Top
End Property
Property Let Top(pTop As Currency)
    pShp.Top = pTop
End Property

Property Get Bottom() As Currency
    Bottom = pShp.Top + pShp.Height
End Property
Property Let Bottom(pBottom As Currency)
    pShp.Top = pBottom - pShp.Height
End Property

Property Get Width() As Currency
    Width = pShp.Width
End Property
Property Let Width(pWidth As Currency)
    pShp.Width = pWidth
End Property

Property Get Height() As Currency
    Height = pShp.Height
End Property
Property Let Height(pHeight As Currency)
    pShp.Height = pHeight
End Property

他愛のないいろんな座標を提供&設定するクラス

でも，このクラスを使うと，さらに前の惑星ぽいやつがこんな風に
chemiphys.hateblo.jp
標準モジュール (変更なし)

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 pR As Currency
Private s1 As ShpCls
Private sc As ShpCls

Public Sub GetR(pShp1 As Shape, pShpCenter As Shape)
    Set s1 = New ShpCls
    Set sc = New ShpCls
    s1.SetShp pShp1
    sc.SetShp pShpCenter
    
     pR = Sqr((s1.X - sc.X) ^ 2 + (s1.Y - sc.Y) ^ 2)
End Sub

Public Sub Move(pShp1 As Shape, pShpCenter As Shape, pAngle As Currency)
    
    s1.X = sc.X + pR * Cos(pAngle)
    s1.Y = sc.Y + pR * Sin(pAngle)

End Sub