熱運動クラスモジュール化④ボックスを複数設置，全体見直し，若干ランダム付与

昨日だいたい出来上がったもので，ボックスを増やしてみました。

職場は64bit環境，書きなおさせられましたが，家の32bitOfficeでも動く。

なるほど，imihitoさんが言ってたのはこのことかーと思いました。

あとは，実際使うときは電子黒板で，キーボードがほぼ使えないので，ボックスをクリックすると速度UP,数値をクリックすると速度Downになるように，つくりかえ。

若干ランダムさを加味して，よりそれっぽくなるようにしてみました。

いちおうこれについては，満足な出来です。

いろいろ教えてもらいながらクラスモジュールに取り組んだ最初の作成品となりました。

標準モジュール

Option Explicit

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As LongPtr)
Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As LongPtr) As LongPtr

Public Const PI = 3.14
Public Const v0 = 3
Public blnStop As Boolean
Const SID = 1
Const Box数 = 3
Public B(1 To Box数) As Box

Sub 熱運動Start()
    ActivePresentation.SlideShowSettings.Run
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID)
    Dim i As Long
    If TSlide.Shapes.Count <> 0 Then
        For i = TSlide.Shapes.Count To 1 Step -1
            TSlide.Shapes(i).Delete
        Next
    End If
    
    With TSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 20, 200, 70)
        .Name = "動作ボタン"
        .ThreeD.BevelTopDepth = 5
        .TextFrame.TextRange = "停止"
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "ONOFF"
    End With
    
    Set B(1) = New Box: B(1).Draw TSlide, 100, 250, 80, 150, 6, 10
    Set B(2) = New Box: B(2).Draw TSlide, 100, 250, 150, 200, 3, 10
    Set B(3) = New Box: B(3).Draw TSlide, 100, 250, 200, 400, 10, 10
    
    For i = 1 To 3
        B(i).Hensoku (True)
        TSlide.Shapes("Spd" & Format(i, "00")).TextFrame.TextRange = 1
    Next
    
    blnStop = False
    Call 動作制御
End Sub
Sub ONOFF()
    Dim ButtonTRG As TextRange: Set ButtonTRG = ActivePresentation.Slides(SID).Shapes("動作ボタン").TextFrame.TextRange
    If blnStop = True Then
        blnStop = False
        ButtonTRG = "停止"
    Else
        blnStop = True
        ButtonTRG = "動かす"
    End If
    
    Call 動作制御
End Sub

Sub 動作制御()
    Dim ButtonTRG As TextRange: Set ButtonTRG = ActivePresentation.Slides(SID).Shapes("動作ボタン").TextFrame.TextRange
    Dim en As Molecule
    Dim i As Long
    
    Do
        For i = 1 To Box数
            For Each en In B(i).Molecules
                en.Move
            Next
        Next
        
        ButtonTRG = ButtonTRG
        DoEvents
        If blnStop = True Then Exit Sub
        Sleep 50
    Loop
    
End Sub
Sub 変速(図形 As Shape)
    Dim str1 As String, BoxID As Long
    str1 = Left(図形.Name, Len(図形.Name) - 2)
    BoxID = CLng(Right(図形.Name, 2))
    
    Dim blnPlus As Boolean
    If str1 = "Box" Then blnPlus = True Else blnPlus = False
    
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID)
    B(BoxID).Hensoku (blnPlus)
    TSlide.Shapes("Spd" & Format(BoxID, "00")).TextFrame.TextRange = B(BoxID).pSpeed
End Sub

Box.cls

Option Explicit

Public pSlide As Slide
Public pTop As Long
Public pBottom As Long
Public pLeft As Long
Public pRight As Long
Public Molecules As Collection
Public pSpeed As Long

Public Sub Draw(objSlide As Slide, lngTop As Long, lngBottom As Long, lngLeft As Long, lngRight As Long, p粒数 As Long, p直径 As Long)
    Set pSlide = objSlide
    pTop = lngTop
    pBottom = lngBottom
    pLeft = lngLeft
    pRight = lngRight
    
    Dim x As Shape
    Dim BoxID As Long: BoxID = 0
    
    If pSlide.Shapes.Count <> 0 Then
        For Each x In pSlide.Shapes
            If Left(x.Name, 3) = "Box" And IsNumeric(Mid(x.Name, 4)) Then
                If CLng(Mid(x.Name, 4)) > BoxID Then BoxID = CLng(Mid(x.Name, 4))
            End If
        Next
        BoxID = BoxID + 1
    End If
    
    With pSlide.Shapes.AddShape(msoShapeRectangle, pLeft, pTop, pRight - pLeft, pBottom - pTop)
        .Name = "Box" & Format(BoxID, "00")
        .Line.Weight = 6
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Fill.Visible = msoFalse
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "変速"
    End With
    
    With pSlide.Shapes.AddShape(msoShapeRoundedRectangle, pLeft, pBottom + 10, pRight - pLeft, 25)
        .Name = "Spd" & Format(BoxID, "00")
        .TextFrame.TextRange = 0
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "変速"
    End With
    
    Call AddMolecule(p粒数, p直径)
End Sub

Public Sub AddMolecule(粒数 As Long, 直径 As Long)
    Dim e() As Molecule
    ReDim e(粒数)
    Dim i As Long
    Set Molecules = New Collection
    
    For i = 1 To 粒数
        Set e(i) = New Molecule
        
        e(i).Add pSlide, 直径, pLeft, pRight, pTop, pBottom
        e(i).pVAngle = PI / 2 * Rnd()
        Molecules.Add e(i)
    Next
End Sub

Public Sub Hensoku(blnPlus As Boolean)
    Dim e As Molecule
    If blnPlus = True Then pSpeed = pSpeed + 1 Else pSpeed = pSpeed - 1
    If pSpeed < 0 Then pSpeed = 0
    
    For Each e In Me.Molecules
        e.Hensoku (pSpeed)
    Next
End Sub

Molecule.cls

Option Explicit

Public pSlide As Slide
Public pVx As Currency
Public pVy As Currency
Public pVAngle As Currency
Public lLeft As Long
Public lRight As Long
Public lTop As Long
Public lBottom As Long
Public shpEn As Shape
Public mSpeed As Long

Public Sub Add(objSlide As Slide, m直径 As Long, lngLimitLeft As Long, lngLimitRight As Long, lngLimitTop As Long, lngLimitBottom As Long)
    lLeft = lngLimitLeft
    lRight = lngLimitRight
    lTop = lngLimitTop
    lBottom = lngLimitBottom

    Set shpEn = objSlide.Shapes.AddShape(msoShapeOval, (lLeft + lRight) / 2, (lTop + lBottom) / 2, m直径, m直径)
    
    shpEn.Fill.ForeColor.RGB = RGB(Int(255 * Rnd()), Int(255 * Rnd()), Int(255 * Rnd()))
    shpEn.ThreeD.BevelTopDepth = m直径 / 2
    shpEn.ThreeD.BevelTopInset = m直径 / 2
    shpEn.Line.Visible = msoFalse
    
    Dim x As Shape
    Dim 粒ID As Long: 粒ID = 0
    If objSlide.Shapes.Count <> 0 Then
        For Each x In objSlide.Shapes
            If Left(x.Name, 1) = "粒" And IsNumeric(Mid(x.Name, 2)) Then
                If CLng(Mid(x.Name, 2)) > 粒ID Then 粒ID = CLng(Mid(x.Name, 2))
            End If
        Next
        粒ID = 粒ID + 1
    End If
    shpEn.Name = "粒" & Format(粒ID, "00")
End Sub

Public Sub Hensoku(lngSpeed)
    mSpeed = lngSpeed
    If pVx >= 0 Then pVx = Abs(v0 * Cos(pVAngle) * mSpeed * (0.8 + Rnd() * 0.4)) Else pVx = -Abs(v0 * Cos(pVAngle) * mSpeed * (0.8 + Rnd() * 0.4))
    If pVy >= 0 Then pVy = Abs(v0 * Sin(pVAngle) * mSpeed * (0.8 + Rnd() * 0.4)) Else pVy = -Abs(v0 * Sin(pVAngle) * mSpeed * (0.8 + Rnd() * 0.4))
End Sub

Public Sub Move()
    shpEn.Left = shpEn.Left + pVx
    shpEn.Top = shpEn.Top + pVy
    
    If shpEn.Left + pVx < lLeft And pVx < 0 Then pVx = -pVx
    If shpEn.Left + shpEn.Width + pVx > lRight And pVx > 0 Then pVx = -pVx
    If shpEn.Top + pVy < lTop And pVy < 0 Then pVy = -pVy
    If shpEn.Top + shpEn.Width + pVy > lBottom And pVy > 0 Then pVy = -pVy
End Sub

動作の様子はこちら。ボタンで全体停止，再開もできるようにつくりました。

クラスモジュールになると，パーツがきちんと分かれるので，さらにここを工夫しようとか，見れる余裕ができてとても楽しい。

ただ，あれもこれもやりたくなって，きりがないので，いちおうここまで。(ﾟ▽ﾟ*)