熱運動クラスモジュール化③速度と動きを実装
明日からまた仕事なので,なんとか動かすところまで行きたかった。
そしてなんとか動くところまでは来ました。
今日はこれ以上はあまり進めませんが,明日からブラッシュアップくらいなら暇な時間にできる。
内容はがっつり仕事の内容なのでコードの描きなおしは職務中にできる。
ブログは書けませんけど・・(゚▽゚*)
帰ってからその日にがんばったことを書くからいい。
Boxを増やしたりとかは試していませんが,最小限実装すべきものの段階で載せます。
キー操作を画面に表示していませんが, A,Zで速度調整,SHIFTで終了です。
標準モジュール
Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As Long) Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long Public Const PI = 3.14 Public Const v0 = 3 Public B1 As Box Sub test() ActivePresentation.SlideShowSettings.Run Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1) 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 Set B1 = New Box B1.Draw TSlide, 100, 250, 80, 150 B1.AddMolecile 5 Dim en As Molecule Do For Each en In B1.Molecules en.Move Next If GetAsyncKeyState(vbKeyA) <> 0 Then キー処理 (vbKeyA) If GetAsyncKeyState(vbKeyZ) <> 0 Then キー処理 (vbKeyZ) If GetAsyncKeyState(16) <> 0 Then Exit Do DoEvents TSlide.Shapes("spd1").TextFrame.TextRange = TSlide.Shapes("spd1").TextFrame.TextRange Sleep 50 Loop SlideShowWindows(1).View.Exit End Sub Sub キー処理(lngKey As Long) Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1) Dim en As Molecule Select Case lngKey Case vbKeyA For Each en In B1.Molecules en.Hensoku (True) Next TSlide.Shapes("Spd1").TextFrame.TextRange = CLng(TSlide.Shapes("Spd1").TextFrame.TextRange) + 1 Case vbKeyZ For Each en In B1.Molecules en.Hensoku (False) Next TSlide.Shapes("Spd1").TextFrame.TextRange = CLng(TSlide.Shapes("Spd1").TextFrame.TextRange) - 1 If CLng(TSlide.Shapes("Spd1").TextFrame.TextRange) < 0 Then TSlide.Shapes("Spd1").TextFrame.TextRange = "0" End Select 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 pSpeed As Long Public Molecules As Collection Public Sub Draw(objSlide As Slide, lngTop As Long, lngBottom As Long, lngLeft As Long, lngRight As Long) Set pSlide = objSlide pTop = lngTop pBottom = lngBottom pLeft = lngLeft pRight = lngRight Dim Box As Shape Set Box = pSlide.Shapes.AddShape(msoShapeRectangle, pLeft, pTop, pRight - pLeft, pBottom - pTop) 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 Box.Name = "Box" & BoxID Box.Line.Visible = msoTrue Box.Line.Weight = 6 Box.Line.ForeColor.RGB = RGB(0, 0, 0) Box.Fill.Visible = msoFalse Dim Label As Shape Set Label = pSlide.Shapes.AddShape(msoShapeRoundedRectangle, pLeft, pBottom + 10, pRight - pLeft, 20) Label.Name = "Spd" & BoxID Label.TextFrame.TextRange = pSpeed End Sub Public Sub AddMolecile(粒数 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).mLeft = pLeft e(i).mTop = pTop e(i).mRight = pRight e(i).mBottom = pBottom Set e(i).pSlide = pSlide e(i).Add 15 e(i).pVAngle = i * (2 * PI / 7) Molecules.Add e(i) Next End Sub
Molcule.cls
Option Explicit Public pSlide As Slide Public pVx As Currency Public pVy As Currency Public pVAngle As Currency Public mLeft As Long '動く領域左端 Public mRight As Long '動く領域右端 Public mTop As Long '動く領域上端 Public mBottom As Long '動く領域下端 Public shpEn As Shape Public pSpeed As Long Public Sub Add(半径 As Long) Set shpEn = pSlide.Shapes.AddShape(msoShapeOval, mLeft + 半径 + (mRight - mLeft - 2 * 半径) * Rnd(), mTop + 半径 + (mBottom - mTop - 2 * 半径) * Rnd(), 半径, 半径) shpEn.Fill.ForeColor.RGB = RGB(Int(255 * Rnd()), Int(255 * Rnd()), Int(255 * Rnd())) shpEn.ThreeD.BevelTopDepth = 半径 / 2 shpEn.ThreeD.BevelTopInset = 半径 / 2 shpEn.Line.Visible = msoFalse Dim x As Shape Dim 粒ID As Long: 粒ID = 0 If pSlide.Shapes.Count <> 0 Then For Each x In pSlide.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(blnPlus As Boolean) If blnPlus = True Then pSpeed = pSpeed + 1 Else pSpeed = pSpeed - 1 If pSpeed < 0 Then pSpeed = 0 If pVx >= 0 Then pVx = Abs(v0 * Cos(pVAngle) * pSpeed) Else pVx = -Abs(v0 * Cos(pVAngle) * pSpeed) If pVy >= 0 Then pVy = Abs(v0 * Sin(pVAngle) * pSpeed) Else pVy = -Abs(v0 * Sin(pVAngle) * pSpeed) End Sub Public Sub Move() shpEn.Left = shpEn.Left + pVx shpEn.Top = shpEn.Top + pVy If shpEn.Left + pVx < mLeft And pVx < 0 Then pVx = -pVx If shpEn.Left + shpEn.Width + pVx > mRight And pVx > 0 Then pVx = -pVx If shpEn.Top + pVy < mTop And pVy < 0 Then pVy = -pVy If shpEn.Top + shpEn.Width + pVy > mBottom And pVy > 0 Then pVy = -pVy End Sub
重複表現は減ったとは思います。分担もそんなには悪くないかなぁ。
速度の表現も前より良くなった気がする。
まだ全貌を見直してませんが動いたのでとりあえず満足(゚▽゚*)
明日ボックスの数を増やしてみて,どうなるか見てみよう。