Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

線に沿う玉の運動を描く⑦ いろいろやる前にカプセル化

これの続きです。
chemiphys.hateblo.jp


速度に法則を適用するのが難しく,頭を悩ませています。

エネルギー保存則を入れたかったんだけど,いろいろと難しかったので,ちょっと違う方向で動きをつけようとしています。

きっとなんとかしようとは思ってます。

とりあえず,前回反省であった,変数が足りなくなる問題。

Publicでなんでも垂れ流しているので,それはそうですよね。。

いろいろ考えてたどり着いたのはClassのメソッドやプロパティはメンバから簡単に選べるので,そこには日本語も積極的に活用しよう。

引数もタイピングする必要の少ないものだから,引数の文字も場合によっては日本語の利用もする。

内部で何度も書いたりする内容については,プライベートやプロパティの気持ちをこめてpを変数名につけていく

このくらいのイメージを頭に持って,昨日までのコードを書きなおしました。

あと,沈まない工夫については,複雑な判定をもう一度するのではなく,重複部分を判断させる図形のHeight,Widthプロパティから大きさを判断し,ある程度の大きさを超えたらそれを打ち消すべく

座標をほんの少しずつずらす。イメージとしては抗力的な感じです。Height,Width両方あれば,いろんな判断をさせられるかなーと思い実装しました。

動きは変ですが,今日のコードとその動きを載せます。

さぁ動きに法則っぽさを足していこう。

f:id:chemiphys:20170117183839p:plain
標準モジュール

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 = 60
    Ball1.Draw TSlide, 40, RGB(255, 255, 0), 15, Y0

    Do
        Ball1.Move TSlide, shpSlope, Y0
        Ball1.BallTxt " "
        DoEvents

    Loop Until Ball1.X > 800

End Sub

Ball.cls

Option Explicit

Private pVx As Currency
Private pVy As Currency
Private pV As Currency
Private shpBall As Shape
Const Gravity = 9.8


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 Let V(速度 As Currency)
'    pV = 速度
'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 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
    
    'pV = (-2 * Gravity * pY0 / 27 + pV0 ^ 2 + 2 * Gravity * shpBall.Top / 27) ^ 0.5
    pV = 3
    
    If 判定.blnCollide = True Then
        pVx = pV * Cos(判定.sglAngle) * Rate
        pVy = pV * Sin(判定.sglAngle) * Rate + 1 * Sin(判定.sglAngle) * Rate
        
        If 判定.重なり高さ > 1 Then shpBall.Top = shpBall.Top - 1
    Else
        pVx = 0
        pVy = pV * Rate
    End If

    shpBall.Left = shpBall.Left + pVx
    shpBall.Top = shpBall.Top + pVy
    
End Sub

Hantei.cls

Option Explicit

Private psglAngle As Single
Private pblnCollide As Boolean
Private shpDupeHeight As Long
Private shpDupeWidth As Long

Public Property Get sglAngle()
    sglAngle = psglAngle
End Property
Public Property Get blnCollide()
    blnCollide = pblnCollide
End Property
Public Property Get 重なり幅()
    重なり幅 = shpDupeWidth
End Property
Public Property Get 重なり高さ()
    重なり高さ = shpDupeHeight
End Property


Sub Judge(hSlide As Slide, shp1 As Shape, shp2 As Shape)
    Dim lngShapeCount As Long
    Dim NextShp1 As Shape
    lngShapeCount = hSlide.Shapes.Count
    hSlide.Shapes.Range(Array(shp1.ZOrderPosition, shp2.ZOrderPosition)).Duplicate.MergeShapes msoMergeIntersect
    
    If hSlide.Shapes.Count = lngShapeCount Then
        pblnCollide = False
        Exit Sub
    Else
        pblnCollide = True
        Dim shpDupe As Shape
        Set shpDupe = hSlide.Shapes(hSlide.Shapes.Count)
    End If
    
    
    Dim shpNodes As ShapeNodes: Set shpNodes = shpDupe.Nodes
    Dim sglMinPtX As Single: sglMinPtX = shpNodes(1).Points(1, 1)
    Dim MinPtXIndex As Long: MinPtXIndex = 1
    Dim i As Long
    For i = 1 To shpNodes.Count - 1
        If shpNodes(i).Points(1, 1) < sglMinPtX Then
            sglMinPtX = shpNodes(i).Points(1, 1)
            MinPtXIndex = i
        End If
    Next
    
    Dim NextPtXIndex As Long
    If shpNodes(MinPtXIndex + 1).Points(1, 1) - shpNodes(MinPtXIndex).Points(1, 1) < 2 And MinPtXIndex + 2 <= shpNodes.Count Then
        NextPtXIndex = MinPtXIndex + 2
    Else
        NextPtXIndex = MinPtXIndex + 1
    End If
    
    If shpNodes(NextPtXIndex).Points(1, 1) - shpNodes(MinPtXIndex).Points(1, 1) > 0.1 Then
        psglAngle = Atn((shpNodes(NextPtXIndex).Points(1, 2) - shpNodes(MinPtXIndex).Points(1, 2)) / (shpNodes(NextPtXIndex).Points(1, 1) - shpNodes(MinPtXIndex).Points(1, 1)))
    Else
        psglAngle = 3.14 / 2
    End If
    
    shpDupeHeight = shpDupe.Height
    shpDupeWidth = shpDupe.Width
    
    shpDupe.Delete

End Sub

f:id:chemiphys:20170117190812g:plain