線に沿う玉の運動を描く④

流れを書いてなかったので追記
chemiphys.hateblo.jp

長くかかるんじゃないかという，ネタな気がしてたんですが，

なんとなく動き出しましたよ!

すごいな　ほんとにできるんだな　笑える(ΦωΦ)ﾌﾌﾌ…

遊んでいる身でなんですが，驚きです。

まだいろんな検証はできていません。コードも後で載せますがまだまだきったない状態。ですが，それっぽく動いたので載せます。

thomさんのページで見ましたが，利用規約か。。わたしも考えないと。一応コードを載せてますしね。。

利用規約を真似させてもらおうかなぁ・・後でその辺は考えよう。

とりあえず動いている姿がこちら。

ちょっとめり込み気味になるところがありますが，ちゃんと線に沿おうとする動きは見えているから，調整できるはず。

コードはこちら。利用は自己責任で!わたしも素人なので，責任など持ちかねます。

玉には　円という名前をつけてください。　玉に次回変えます(ﾟ▽ﾟ*)
下の斜面はフリーフォームで閉じた図形を描いてFFormという名前を付けてください。
勢いで載せすぎでいろいろ書いてないですね　玉は動かす前に左上らへんに持って行ってあげてください_(._.)_

Sub 当たり判定()
    ActivePresentation.SlideShowSettings.Run
    Dim shp(5) As Shape
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)

    
    Set shp(1) = TSlide.Shapes("円")
    Set shp(2) = TSlide.Shapes("FForm")
    
    Dim dX As Single, dY As Single
    dX = 2
    dY = 2
    Dim i As Long
    
    Do
    
        TSlide.Shapes.Range(Array(shp(1).ZOrderPosition, shp(2).ZOrderPosition)).Duplicate.MergeShapes msoMergeIntersect
        
        If TSlide.Shapes.Count <> 3 Then
            shp(1).Top = shp(1).Top + dY
        
        Else
            Set shp(3) = TSlide.Shapes(3)
            
            Dim shpNodes As ShapeNodes: Set shpNodes = shp(3).Nodes
            Dim sglMinPtX As Single: sglMinPtX = shpNodes(1).Points(1, 1)
            Dim lngMinPtXIndex As Long: lngMinPtXIndex = 1
            For i = 1 To shpNodes.Count - 1
                If shpNodes(i).Points(1, 1) < sglMinPtX Then
                    sglMinPtX = shpNodes(i).Points(1, 2)
                    lngMinPtXIndex = i
                End If
            Next
            
            Dim lngNextPtXIndex As Long
            If shpNodes(lngMinPtXIndex + 1).Points(1, 1) - shpNodes(lngMinPtXIndex).Points(1, 1) < 2 And lngMinPtXIndex + 2 <= shpNodes.Count Then
                lngNextPtXIndex = lngMinPtXIndex + 2
            Else
                lngNextPtXIndex = lngMinPtXIndex + 1
            End If
            Dim Rad As Single
            Rad = Atn((shpNodes(lngNextPtXIndex).Points(1, 2) - shpNodes(lngMinPtXIndex).Points(1, 2)) / (shpNodes(lngNextPtXIndex).Points(1, 1) - shpNodes(lngMinPtXIndex).Points(1, 1)))
            
            shp(1).Left = shp(1).Left + dX
            shp(1).Top = shp(1).Top + dX * Tan(Rad)
            shp(3).Delete
        End If
        shp(1).TextFrame.TextRange = "F"
        
        DoEvents
        
    Loop Until shp(1).Left > 700
End Sub

とりあえず動くことを目指しているレベルなので，当然きちんとコードは書けてはしません。

でもなんとなく動き出したので，きちんと見直しを始めます。

追記　フリーフォーム適当に描きなおしても動きました。イイネ