Powerpoint VBA 熱運動の視覚化に挑戦
わたしがパワーポイントのVBAで最初に実現しようとしたものです。
分子の熱運動はしゃべってても こぶしを分子に見立てて ふるわせてもいまいち伝わっていない空気がこちらに伝わってくる。
そこで,3つのボックスに粒を入れ,激しく動いている隣のボックス内の動きをすこしずつ早くしていき,それがまた次のに少しずつ伝わっていく
ということを手元で調整していけるものを作ってみようという考えです。
もともと作ったものをコードだけで動くように書き直したら 元が長かったのがさらに長くなりました(;´▽`A``
いいわけ込みですが,きちんと分子運動を実現しているわけではなく,それっぽく動かしているだけです(ΦωΦ)
動作画面はこんな感じです。
電子黒板でやるときは,キーボードの操作ができないのでボタンで速度の上下をしないといけないですね。
コードでそれをやるのは面倒だったのでキーで制御です
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
もっといろいろな部分を部品化して見やすいコードにすべきですが,
きちんと考えて分解していかないとですね。。
最初に取り組んでなかなかイイネと自画自賛した 最初の理科っぽいものでした。