インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

熱運動クラスモジュール化③速度と動きを実装

明日からまた仕事なので,なんとか動かすところまで行きたかった。

そしてなんとか動くところまでは来ました。

今日はこれ以上はあまり進めませんが,明日からブラッシュアップくらいなら暇な時間にできる。

内容はがっつり仕事の内容なのでコードの描きなおしは職務中にできる。

ブログは書けませんけど・・(゚▽゚*)

帰ってからその日にがんばったことを書くからいい。

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

重複表現は減ったとは思います。分担もそんなには悪くないかなぁ。
速度の表現も前より良くなった気がする。

まだ全貌を見直してませんが動いたのでとりあえず満足(゚▽゚*)

f:id:chemiphys:20170115225510g:plain
明日ボックスの数を増やしてみて,どうなるか見てみよう。