Powerpoint VBAを使おう!

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

Powerpoint VBA 熱運動の視覚化に挑戦

わたしがパワーポイントのVBAで最初に実現しようとしたものです。

分子の熱運動はしゃべってても こぶしを分子に見立てて ふるわせてもいまいち伝わっていない空気がこちらに伝わってくる。

そこで,3つのボックスに粒を入れ,激しく動いている隣のボックス内の動きをすこしずつ早くしていき,それがまた次のに少しずつ伝わっていく

ということを手元で調整していけるものを作ってみようという考えです。

もともと作ったものをコードだけで動くように書き直したら 元が長かったのがさらに長くなりました(;´▽`A``

いいわけ込みですが,きちんと分子運動を実現しているわけではなく,それっぽく動かしているだけです(ΦωΦ)

動作画面はこんな感じです。
f:id:chemiphys:20170114120139g:plain

電子黒板でやるときは,キーボードの操作ができないのでボタンで速度の上下をしないといけないですね。
コードでそれをやるのは面倒だったのでキーで制御です

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

Const PI = 3.14
Const Box1Left = 80, Box1Top = 100, Box1Right = 150, Box1Bottom = 250
Const Box2Left = 150, Box2Top = 100, Box2Right = 200, Box2Bottom = 250
Const Box3Left = 200, Box3Top = 100, Box3Right = 300, Box3Bottom = 250
Const Tsubu1 = 4, Tsubu2 = 4, Tsubu3 = 5
Const bytUP1 = vbKeyA, bytDown1 = vbKeyZ
Const bytUp2 = vbKeyS, bytDown2 = vbKeyX
Const bytUP3 = vbKeyD, bytDown3 = vbKeyC
Sub 熱運動()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim i As Long, V0_1 As Byte, V0_2 As Byte, V0_3 As Byte
    
    On Error Resume Next
        For i = TSlide.Shapes.Count To 1 Step -1
            TSlide.Shapes(i).Delete
            'If TSlide.Shapes(i).Name <> "開始ボタン" Then TSlide.Shapes(i).Delete  '残したい図形の名前を指定
        Next
    On Error GoTo 0
    
    ActivePresentation.SlideShowSettings.Run
    
    TSlide.Shapes.AddTextEffect msoTextEffect02, "SHIFTで停止" & Chr(10) & "A,ZでBox1" & Chr(10) & "S,XでBox2" & Chr(10) & "D,CでBox3の調節", "Meiryo UI", 20, msoFalse, msoFalse, 350, 100
    
    V0_1 = 1
    V0_2 = 1
    V0_3 = 1

    Dim Box(3)
    Set Box(1) = TSlide.Shapes.AddShape(msoShapeRectangle, Box1Left, Box1Top, Box1Right - Box1Left, Box1Bottom - Box1Top)
    Set Box(2) = TSlide.Shapes.AddShape(msoShapeRectangle, Box2Left, Box2Top, Box2Right - Box2Left, Box2Bottom - Box2Top)
    Set Box(3) = TSlide.Shapes.AddShape(msoShapeRectangle, Box3Left, Box3Top, Box3Right - Box3Left, Box3Bottom - Box3Top)
    
    For i = 1 To 3
        Box(i).Line.Visible = msoTrue
        Box(i).Line.Weight = 6
        Box(i).Line.ForeColor.RGB = RGB(0, 0, 0)
        Box(i).Fill.Visible = msoFalse
        Box(i).Name = "box" & i
    Next
    
    Dim Label1 As Shape, Label2 As Shape, Label3 As Shape
    Set Label1 = TSlide.Shapes.AddShape(msoShapeRoundedRectangle, Box1Left, Box1Bottom + 10, Box1Right - Box1Left, 20)
    Set Label2 = TSlide.Shapes.AddShape(msoShapeRoundedRectangle, Box2Left, Box2Bottom + 10, Box2Right - Box2Left, 20)
    Set Label3 = TSlide.Shapes.AddShape(msoShapeRoundedRectangle, Box3Left, Box3Bottom + 10, Box3Right - Box3Left, 20)
    
    Label1.TextFrame.TextRange.Text = V0_1
    Label2.TextFrame.TextRange.Text = V0_2
    Label3.TextFrame.TextRange.Text = V0_3
    
    Dim ShpEn(Tsubu1 + Tsubu2 + Tsubu3) As Shape
        Randomize
        For i = 1 To Tsubu1
            Set ShpEn(i) = TSlide.Shapes.AddShape(msoShapeOval, (Box1Left + Box1Right) / 2, (Box1Top + Box1Bottom) / 2, 15, 15)
            ShpEn(i).Fill.ForeColor.RGB = RGB(Int(255 * Rnd()), Int(255 * Rnd()), Int(255 * Rnd()))
            ShpEn(i).ThreeD.BevelTopDepth = 7
            ShpEn(i).ThreeD.BevelTopInset = 7
            ShpEn(i).Line.Visible = msoFalse
            ShpEn(i).Name = En & Format(i, "00")
        Next
        For i = Tsubu1 + 1 To Tsubu1 + Tsubu2
            Set ShpEn(i) = TSlide.Shapes.AddShape(msoShapeOval, (Box2Left + Box2Right) / 2, (Box2Top + Box2Bottom) / 2, 15, 15)
            ShpEn(i).Fill.ForeColor.RGB = RGB(Int(255 * Rnd()), Int(255 * Rnd()), Int(255 * Rnd()))
            ShpEn(i).ThreeD.BevelTopDepth = 7
            ShpEn(i).ThreeD.BevelTopInset = 7
            ShpEn(i).Line.Visible = msoFalse
            ShpEn(i).Name = En & Format(i, "00")
        Next
        For i = Tsubu1 + Tsubu2 + 1 To Tsubu1 + Tsubu2 + Tsubu3
            Set ShpEn(i) = TSlide.Shapes.AddShape(msoShapeOval, (Box3Left + Box3Right) / 2, (Box3Top + Box3Bottom) / 2, 15, 15)
            ShpEn(i).Fill.ForeColor.RGB = RGB(Int(255 * Rnd()), Int(255 * Rnd()), Int(255 * Rnd()))
            ShpEn(i).ThreeD.BevelTopDepth = 7
            ShpEn(i).ThreeD.BevelTopInset = 7
            ShpEn(i).Line.Visible = msoFalse
            ShpEn(i).Name = En & Format(i, "00")
        Next
        
    Dim Vx() As Single
    Dim Vy() As Single
    ReDim Vx(Tsubu1 + Tsubu2 + Tsubu3)
    ReDim Vy(Tsubu1 + Tsubu2 + Tsubu3)
    
    For i = 1 To Tsubu1
        Vx(i) = V0_1 * Cos(PI * 2 / 7 * (i + 1))
        Vy(i) = V0_1 * Sin(PI * 2 / 7 * (i + 1))
    Next
    For i = Tsubu1 + 1 To Tsubu1 + Tsubu2
        Vx(i) = V0_2 * Cos(PI * 2 / 7 * (i + 1))
        Vy(i) = V0_2 * Sin(PI * 2 / 7 * (i + 1))
    Next
    For i = Tsubu1 + Tsubu2 + 1 To Tsubu1 + Tsubu2 + Tsubu3
        Vx(i) = V0_3 * Cos(PI * 2 / 7 * (i + 1))
        Vy(i) = V0_3 * Sin(PI * 2 / 7 * (i + 1))
    Next
    
    Do
        
        If GetAsyncKeyState(bytUP1) <> 0 Then
            For i = 1 To Tsubu1
                Vx(i) = HensokuX(Vx(i), i, True)
                Vy(i) = HensokuY(Vy(i), i, True)
            Next
            Label1.TextFrame.TextRange.Text = Label1.TextFrame.TextRange.Text + 1
        End If
        
        If GetAsyncKeyState(bytDown1) <> 0 Then
            For i = 1 To Tsubu1
                Vx(i) = HensokuX(Vx(i), i, False)
                Vy(i) = HensokuY(Vy(i), i, False)
            Next
            If Label1.TextFrame.TextRange.Text <> 0 Then Label1.TextFrame.TextRange.Text = Label1.TextFrame.TextRange.Text - 1
        End If
        
        If GetAsyncKeyState(bytUp2) <> 0 Then
            For i = Tsubu1 + 1 To Tsubu1 + Tsubu2
                Vx(i) = HensokuX(Vx(i), i, True)
                Vy(i) = HensokuY(Vy(i), i, True)
            Next
            Label2.TextFrame.TextRange.Text = Label2.TextFrame.TextRange.Text + 1
        End If
        
        If GetAsyncKeyState(bytDown2) <> 0 Then
        
            For i = Tsubu1 + 1 To Tsubu1 + Tsubu2
                Vx(i) = HensokuX(Vx(i), i, False)
                Vy(i) = HensokuY(Vy(i), i, False)
            Next
            If Label2.TextFrame.TextRange.Text <> 0 Then Label2.TextFrame.TextRange.Text = Label2.TextFrame.TextRange.Text - 1
        End If
        
        If GetAsyncKeyState(bytUP3) <> 0 Then

            For i = Tsubu1 + Tsubu2 + 1 To Tsubu1 + Tsubu2 + Tsubu3
                Vx(i) = HensokuX(Vx(i), i, True)
                Vy(i) = HensokuY(Vy(i), i, True)
            Next
            Label3.TextFrame.TextRange.Text = Label3.TextFrame.TextRange.Text + 1
        End If
        
        If GetAsyncKeyState(bytDown3) <> 0 Then
        
            For i = Tsubu1 + Tsubu2 + 1 To Tsubu1 + Tsubu2 + Tsubu3
                Vx(i) = HensokuX(Vx(i), i, False)
                Vy(i) = HensokuY(Vy(i), i, False)
            Next
            If Label3.TextFrame.TextRange.Text <> 0 Then Label3.TextFrame.TextRange.Text = Label3.TextFrame.TextRange.Text - 1
        End If
       
        For i = 1 To Tsubu1 + Tsubu2 + Tsubu3
            ShpEn(i).Left = ShpEn(i).Left + Vx(i)
            ShpEn(i).Top = ShpEn(i).Top + Vy(i)
            DoEvents
                       
            Select Case i
                Case Is <= Tsubu1
                    If ShpEn(i).Left + Vx(i) < Box1Left And Vx(i) < 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Left + ShpEn(i).Width + Vx(i) > Box1Right And Vx(i) > 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Top + Vy(i) < Box1Top And Vy(i) < 0 Then Vy(i) = -Vy(i)
                    If ShpEn(i).Top + ShpEn(i).Width + Vy(i) > Box1Bottom And Vy(i) > 0 Then Vy(i) = -Vy(i)
                Case Is <= Tsubu1 + Tsubu2
                    If ShpEn(i).Left + Vx(i) < Box2Left And Vx(i) < 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Left + ShpEn(i).Width + Vx(i) > Box2Right And Vx(i) > 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Top + Vy(i) < Box2Top And Vy(i) < 0 Then Vy(i) = -Vy(i)
                    If ShpEn(i).Top + ShpEn(i).Width + Vy(i) > Box2Bottom And Vy(i) > 0 Then Vy(i) = -Vy(i)
                Case Else
                    If ShpEn(i).Left + Vx(i) < Box3Left And Vx(i) < 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Left + ShpEn(i).Width + Vx(i) > Box3Right And Vx(i) > 0 Then Vx(i) = -Vx(i)
                    If ShpEn(i).Top + Vy(i) < Box3Top And Vy(i) < 0 Then Vy(i) = -Vy(i)
                    If ShpEn(i).Top + ShpEn(i).Width + Vy(i) > Box3Bottom And Vy(i) > 0 Then Vy(i) = -Vy(i)
            End Select
        Next

        Label3.TextFrame.TextRange.Text = Label3.TextFrame.TextRange.Text  'アニメーションを安定動作させるためにテキストを1つ更新する
        If GetAsyncKeyState(16) <> 0 Then Exit Do
    Loop

SlideShowWindows(1).View.Exit

End Sub

Function HensokuX(Vx As Single, i As Long, blnKasoku As Boolean)
    Dim dVx As Single
    dVx = Abs(Cos(PI * 2 / 7 * (i + 1)))

    If Vx > 0 Then
        If blnKasoku = True Then
            Vx = Vx + dVx
        Else
            If Vx = 0 Then Exit Function
            Vx = Vx - dVx
        End If
    Else
        If blnKasoku = True Then
            Vx = Vx - dVx
        Else
            If Vx = 0 Then Exit Function
            Vx = Vx + dVx
        End If
    End If
    
    HensokuX = Vx

End Function
Function HensokuY(Vy As Single, i As Long, blnKasoku As Boolean)
    Dim dVy As Single
    dVy = Abs(Sin(PI * 2 / 7 * (i + 1)))

    If Vy > 0 Then
        If blnKasoku = True Then
            Vy = Vy + dVy
        Else
            If Vy = 0 Then Exit Function
            Vy = Vy - dVy
        End If
    Else
        If blnKasoku = True Then
            Vy = Vy - dVy
        Else
            If Vy = 0 Then Exit Function
            Vy = Vy + dVy
        End If
    End If
    
    HensokuY = Vy

End Function

もっといろいろな部分を部品化して見やすいコードにすべきですが,
きちんと考えて分解していかないとですね。。

最初に取り組んでなかなかイイネと自画自賛した 最初の理科っぽいものでした。