線に沿う玉の運動を描く⑩ ⑨で載せたものを説明

chemiphys.hateblo.jp
続きです。

今回めりこまないように，斜面に沿うように動くガイドをしたのは，とても単純

重なりの図形と円の中心の距離を出して，半径にひとしくなるように，毎回補正することにしました。

もちろん，速度等に誤差だらけだとめちゃくちゃになるので，速度等の誤差も小さくして，微調整をつねにやる。

速度については高さから算出するので，速度の誤差は連動して大きくなるようにはしていません。

とはいえ，ぶつかる分の誤差はどんどん出ていくので，厳密にかんがえるならめちゃくちゃでしょうけど，

斜面書くだけでそれっぽく動けば，十分目的を達します。

コードはこちら。今から詰めていくので，たたき台です。

動かす時は，坂を適当に描いてもらって slopeという名前を付けてあげてください。

標準モジュール

Option Explicit
Public Const Rate As Currency = 1
Const SID = 1

Sub Test()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID)
    Dim Ball1 As Ball: Set Ball1 = New Ball
    Dim shpSlope As Shape: Set shpSlope = TSlide.Shapes("slope")
    
    ActivePresentation.SlideShowSettings.Run
    
    Dim Y0 As Long: Y0 = 58
    Ball1.Draw TSlide, 40, RGB(255, 255, 0), 15, Y0
    
    Do
        Ball1.Move TSlide, shpSlope, Y0
        Ball1.BallTxt " "
        DoEvents
        If Ball1.X > 900 Then Exit Do
    Loop

End Sub

Ball.cls

Option Explicit

Private pVx As Currency
Private pVy As Currency
Private pV As Currency
Private shpBall As Shape
Private pY As Currency

Public Sub BallTxt(txtBall As String)
    shpBall.TextFrame.TextRange = txtBall
End Sub
    
Public Property Get Vx() As Currency
    Vx = pVx
End Property
Public Property Get Vy() As Currency
    Vy = pVy
End Property

Public Property Get V() As Currency
    V = pV
End Property
Public Property Get X() As Currency
    X = shpBall.Left
End Property
Public Property Get Y() As Currency
    X = shpBall.Top
End Property

Public Property Let X(X座標 As Currency)
    shpBall.Left = X座標
End Property
Public Property Let Y(Y座標 As Currency)
    shpBall.Top = Y座標
End Property


Sub Draw(pSlide As Slide, 直径 As Long, 色 As Long, pX As Long, pY As Long)
    Set shpBall = pSlide.Shapes.AddShape(msoShapeOval, pX, pY, 直径, 直径)
    shpBall.Fill.ForeColor.RGB = 色
    shpBall.Line.ForeColor.RGB = RGB(0, 0, 0)
    shpBall.Line.Weight = 2
    
End Sub

Sub Move(pSlide As Slide, pShpCollide As Shape, pY0 As Long)
    
    Dim 判定 As Hantei: Set 判定 = New Hantei
    判定.Judge pSlide, shpBall, pShpCollide
    shpBall.Top = shpBall.Top + 1
        
    If 判定.blnCollide = True Then
        pV = Sqr(Abs((100 - (500 - shpBall.Top) / 4) * 2)) * 0.4

        pVx = pV * Sin(判定.sglAngle) * Rate
        pVy = pV * Cos(判定.sglAngle) * Rate * 判定.符号
        
'        With pSlide.Shapes.AddLine(判定.DupeX, 判定.DupeY, 判定.DupeX + pVx * 30, 判定.DupeY + pVy * 30)
'            .Line.ForeColor.RGB = vbRed
'            .Line.EndArrowheadStyle = msoArrowheadOpen
'        End With
    Else
        pVx = 0
        pVy = 1
    End If

    shpBall.Left = shpBall.Left + pVx + 判定.X補正 * 判定.符号
    shpBall.Top = shpBall.Top + pVy - 判定.Y補正
 
End Sub

Hantei.cls

Option Explicit

Private psglAngle As Single
Private pblnCollide As Boolean
Private shpDupeHeight As Long
Private shpDupeWidth As Long
Private plusL As Currency
Private plusT As Currency
Private Fugou As Long
Private DupeXCenter As Currency
Private DupeYCenter As Currency
Public Property Get sglAngle()
    sglAngle = psglAngle
End Property
Public Property Get blnCollide()
    blnCollide = pblnCollide
End Property
Public Property Get X補正()
    X補正 = plusL
End Property
Public Property Get Y補正()
    Y補正 = plusT
End Property
Public Property Get 符号()
    符号 = Fugou
End Property
Public Property Get DupeX()
    DupeX = DupeXCenter
End Property
Public Property Get DupeY()
    DupeY = DupeYCenter
End Property

Sub Judge(pSlide As Slide, shp1 As Shape, shp2 As Shape)
    Dim lngShapeCount As Long
    Dim NextShp1 As Shape
    lngShapeCount = pSlide.Shapes.Count
    pSlide.Shapes.Range(Array(shp1.Name, shp2.Name)).Duplicate.MergeShapes msoMergeIntersect
    
    If pSlide.Shapes.Count = lngShapeCount Then
        pblnCollide = False
        Exit Sub
    End If
    
    pblnCollide = True
    Dim shp1XCenter As Currency, shp1YCenter As Currency
    Dim shpDupe As Shape
    Set shpDupe = pSlide.Shapes(pSlide.Shapes.Count)
        
    shpDupe.Left = shpDupe.Left - 12  'duplicateによるずれを戻す
    shpDupe.Top = shpDupe.Top - 12
    
    DupeXCenter = shpDupe.Left + shpDupe.Width / 2
    DupeYCenter = shpDupe.Top + shpDupe.Height / 2
    shp1XCenter = shp1.Left + shp1.Width / 2
    shp1YCenter = shp1.Top + shp1.Height / 2
        
'        With pSlide.Shapes.AddLine(shp1XCenter, shp1YCenter, DupeXCenter, DupeYCenter)
'            .ShapeStyle = msoShapeStylePreset5
'        End With
    
    If Abs(DupeXCenter - shp1XCenter) > 0.01 Then
            psglAngle = Atn(Abs(DupeYCenter - shp1YCenter) / Abs(DupeXCenter - shp1XCenter))
    Else
        psglAngle = 3.14 / 2
    End If
    
    Dim p差 As Currency: p差 = 19.5 - Sqr((DupeYCenter - shp1YCenter) ^ 2 + (DupeXCenter - shp1XCenter) ^ 2)
    plusL = p差 * Cos(psglAngle)

    plusT = p差 * Sin(psglAngle)

    If DupeXCenter > shp1XCenter Then Fugou = -1 Else Fugou = 1

    shpDupe.Delete

End Sub

コメントアウトしているのは，中心から引く垂線や，速度が正しい方向を向いているかチェックする線を描く部分です。

書かせてみるとこんな感じ。すごい見にくいですが，

きちんと接線方向に速度が出ていることはわかります。

こちらは垂線

きちんと取れてる。

残念ながら，今は距離のロスがでているようで，最初の高さまで登ってきません。エネルギーの保存ができていない（ΦωΦ）
今は円の中心方向にひっぱり戻しているので，その積み重なった誤差のせいで登れないかなと思います。

距離のロスがでないように，どうやっていくかということも課題の一つですが，まぁそれはあまり気にはしていない。

それよりも，きちんと動きを考えて，アークタンジェントで角度を取っているので，符号などもきちんと反映させられるはず。

うまく描きなおして，ぜひ坂を上った後スタート側に戻ってくるような動きを実現して，このネタを終わらせるつもり。

もうちょいがんばろう。。

とにかくいろんなところは適当なので，それっぽいのを作ったところだけを見ていただければ(´▽`) '`,、'`,、