二物体間の位置関係を計算するクラス

玉を転がすために，役に立つためのクラスを少しずつ作り中。

１物体に関するクラスと連携させて，速度や加速度をどうにか加えていけるように考える。

クラスに速度や加速度のことを作れたら，ずいぶん制御が楽になる気がしています。うまくいくかどうかはわかりませんが，クラスも作れば作るほど慣れてくるのでガンバラナイト。

まぁ御託は並べますがたいしたものではありません・・(;´▽｀A``

atn関数に条件を加えて，きちんと1回転どの方向もrad単位で返すようには作れたとは思います。

座標はきちんと取れてるので，目的に応じて取れるかな。

実際に適用してみないと，足りないプロパティとかも出てくるので，まだまだですが，

なんとかできあがっていきそうなクラスになってきた。

Corr.cls

Option Explicit
Const PI As Currency = 3.1415
Private pAngle As Currency
Private pAngleCol As Currency
Private pDist As Currency
Private pDistCol As Currency
Private pblnColl As Boolean
Property Get bln当たり() As Boolean
    bln当たり = pblnColl
End Property
Property Get 角度() As Currency
    角度 = pAngle
End Property

Property Get 距離() As Currency
    距離 = pDist
End Property

Property Get 重なり距離() As Currency
    重なり距離 = pDistCol
End Property

Public Sub 当たり判定(sShp As Shape, tShp As Shape)
    Dim pSlide As Slide: Set pSlide = ActivePresentation.Slides(sShp.Parent.SlideIndex)
    Dim lngShpNo As Long: lngShpNo = pSlide.Shapes.Count
    
    pSlide.Shapes.Range(Array(sShp.Name, tShp.Name)).Duplicate.MergeShapes msoMergeIntersect
    
    Dim sS As ShpCls: Set sS = New ShpCls: sS.SetShp sShp
    Dim tS As ShpCls: Set tS = New ShpCls: tS.SetShp tShp
    
    pAngle = Angle(tS.x - sS.x, tS.y - sS.y)
    pDist = Sqr((tS.x - sS.x) ^ 2 + (tS.y - sS.y) ^ 2)

    If pSlide.Shapes.Count = lngShpNo Then
        pblnColl = False
        Exit Sub
    End If
    
    pblnColl = True
    Dim dS As ShpCls: Set dS = New ShpCls: dS.SetShp pSlide.Shapes(pSlide.Shapes.Count)
    dS.x = dS.x - 12: dS.y = dS.y - 12 'Duplicateのずれの訂正
        
'    With pSlide.Shapes.AddLine(sS.x, sS.y, dS.x, dS.y)
'        .Line.ForeColor.RGB = vbBlue
'    End With
    pDistCol = Sqr((dS.x - sS.x) ^ 2 + (dS.y - sS.y) ^ 2)
    
    dS.Delete
End Sub

Function Angle(x As Currency, y As Currency)
    Dim pHosei As Currency
    If Abs(x) < 0.01 Then
        If y > 0 Then
            Angle = PI / 2
        ElseIf y < 0 Then
            Angle = -PI / 2
        Else
            Angle = 0 '(;´▽｀A``
        End If
    Else
        If x > 0 Then
            If y >= 0 Then pHosei = 0 Else pHosei = 2 * PI
        Else
            If y >= 0 Then pHosei = PI Else pHosei = PI
        End If
        Angle = Atn(y / x)
    End If
    Angle = Angle + pHosei
End Function

ShpCls.cls 'Deleteメソッドを付け加えました。

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

Public Sub Delete()
    pShp.Delete
End Sub

ローカルウィンドウを見るための標準モジュール

Option Explicit
Sub a()
Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(2)
Dim testcls As CorrCls: Set testcls = New CorrCls
Dim s1 As Shape: Set s1 = TSlide.Shapes("s1")
Dim s2 As Shape: Set s2 = TSlide.Shapes("s2")

testcls.当たり判定 s1, s2

Stop
End Sub

s1,s2と名前をつけた図形を二つてきとーに置いたら標準モジュールで位置関係を取れます。

次はちゃんと，玉を転がす奴に使ってみよう。。