Powerpoint VBAで波動シミュレーションを作成②

chemiphys.hateblo.jp

前回はほとんどの機能が未実装だったので，今日少しは時間が取れたので，進めてみました。

いろいろと機能を実装しています。

まだきちんと動いているかどうかの検証はできていませんが，(本人あくまでも波動苦手ですので)

それっぽいです!

反射波などの合成波とかを考えられるように，カウントスワップとかも用意しました。これもそれなりに，それっぽく動いています。

けっこう完成にちかいかなーと思っています。見た目は。。

検証によりますが。。

標準モジュール

Option Explicit
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As Long)

Const PI As Currency = 3.1415

Public tCount As Long
Public TargetSlide As Slide
Dim flgStop As Boolean

Sub test()
flgStop = False
Set TargetSlide = ActivePresentation.Slides(1)
Dim Wave1 As Wave: Set Wave1 = New Wave
Dim Wave2 As Wave: Set Wave2 = New Wave
Dim Wave3 As Wave: Set Wave3 = New Wave

Dim retshp As Shape
Dim counter As Long: counter = 1
Dim MixWave As Variant
ReDim MixWave(1 To 2)
TargetSlide.Shapes.Range.Delete
ActivePresentation.SlideShowSettings.Run

'枠作成-----
With TargetSlide.Shapes.AddShape(msoShapeRectangle, 80, 50, 800, 440)
    .Line.Weight = 2
    .Line.ForeColor.RGB = vbBlack
    .Fill.Visible = msoFalse
End With
'StopButton-----
With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 80, 10, 100, 50)
    .ActionSettings(ppMouseClick).Action = ppActionRunMacro
    .ActionSettings(ppMouseClick).Run = "StopMacro"
    .Line.Weight = 2
    .Fill.ForeColor.RGB = vbRed
    .Fill.Visible = msoTrue
    .TextFrame.TextRange = "STOP"
End With


Do
    Wave1.DeleteShp
    Wave1.SetWave(波源X:=0, 向き:=True) = counter
    
    Wave2.DeleteShp
    Wave2.SetWave(波源X:=160, 向き:=False, cntSwap:=80, 位相ずれ:=PI) = counter
    
    Wave3.DeleteShp
    Wave3.SetWave = counter
    Set MixWave(1) = Wave1.WaveCol
    Set MixWave(2) = Wave2.WaveCol
    Wave3.WaveCol = Wave3.合成波(MixWave)
    
    Set retshp = Wave3.GetWaveShape(vbGreen)
    Set retshp = Wave1.GetWaveShape
    Set retshp = Wave2.GetWaveShape(vbRed)
    
    counter = counter + 1
    
    DoEvents
    If flgStop = True Then Exit Do
    Sleep 100
    
Loop

SlideShowWindows(1).View.Exit

End Sub
Sub StopMacro()
    flgStop = True
End Sub
Function SIndex(ByVal TargetShape As PowerPoint.Shape) As Long
    
    If TargetShape.Child = msoTrue Then '完全に真似させてもらった。グループ内図形の場合は親を返す
        Let SIndex = SIndex(TargetShape.ParentGroup)
        Exit Function
    End If
    
    Dim db As Object: Set db = CreateObject("Scripting.Dictionary")
    Dim s As Shape
    Dim i As Long: i = 1
    
    For Each s In TargetSlide.Shapes
        db(s.Id) = i
        i = i + 1
    Next
    
    Let SIndex = db.Item(TargetShape.Id)
    
End Function

Wave.cls

Option Explicit

Const PI As Currency = 3.1415
Const ポイント数 = 160
Const BaseY As Long = 270
Const A As Long = 100
Const dP = 2 * 3.1415 / 40
Const dX As Long = 5
Const StartX As Long = 80
Const StartY As Long = 270

Private 振幅 As Currency
Private p波源 As Long
Private WPX As Collection
Private WPCount As Long
Private p向き As Boolean
Private ptNomax As Long
Private ptNo As Long
Private Shp As Shape
Private HasShape As Boolean
Private IsMix As Boolean
Private IsStart As Boolean

Private Sub Class_Initialize()
    HasShape = False
    IsMix = False
End Sub

Property Let SetWave(Optional cntSwap As Long = 0, Optional ptNomax As Long = 160, _
    Optional 波源X As Long = 0, Optional 向き As Boolean = True, Optional 位相ずれ As Currency, _
    Optional 振幅倍率 As Currency = 1, Optional 速度倍率 As Currency = 1, cnt As Long)
    
    Set WPX = New Collection
    Do
        WPX.Add 0
    Loop Until WPX.Count = ポイント数 + 1

    If cnt < cntSwap Then
        Exit Property
        IsStart = False
    End If
    IsStart = True
    
    p波源 = 波源X
    If 波源X < 0 Then 波源X = 0
    If 波源X > ポイント数 Then 波源X = ポイント数
    WPCount = cnt - cntSwap
    ptNo = 0
    p向き = 向き

    Dim Y As Currency
    Dim i As Long
    For i = 1 To 2 * 速度倍率 * WPCount
        Y = A * 振幅倍率 * Sin(i / 速度倍率 * dP - 位相ずれ)
        ptNo = ptNo + 1
        
        If p向き = True Then
            If ptNo >= 160 - p波源 Then ptNo = ポイント数 - p波源
            WPX.Add Y, before:=p波源 + 1
            WPX.Remove WPX.Count
        Else
            If ptNo > p波源 + 1 Then ptNo = p波源
            WPX.Add Y, after:=p波源 + 1
            WPX.Remove 1
        End If
        If ptNo > ptNomax Then ptNo = ptNomax
    Next
    
End Property
Property Get WaveCol() As Collection
    Set WaveCol = WPX
End Property
Property Let WaveCol(pWaveCol As Collection)
    Set WPX = pWaveCol
End Property
Property Get 波源X() As Long
    波源X = p波源
End Property

Public Function GetWaveShape(Optional LineColor As Long = vbCyan) As Shape
    Dim shp波源 As Shape
    If IsMix = False Or IsStart = False Then
        Set shp波源 = TargetSlide.Shapes.AddShape(msoShapeOval, StartX + p波源 * dX - 7.5, StartY - WPX(p波源 + 1) - 7.5, 15, 15)
        shp波源.Fill.ForeColor.RGB = LineColor
        shp波源.Fill.Visible = msoTrue
        shp波源.TextFrame.TextRange = " "
    End If
    HasShape = True
    
    If IsMix Then ptNo = 160
    If ptNo < 2 Then
        Set Shp = shp波源
        Set GetWaveShape = Shp
        Exit Function
    End If
    
    Dim drwWave As FreeformBuilder, ShpWave As Shape
    Set drwWave = TargetSlide.Shapes.BuildFreeform(msoEditingAuto, StartX + p波源 * dX, StartY - WPX(p波源 + 1))
    Dim i As Long
    Dim StartI As Long, EndI As Long, stepI As Long
    If p向き = True Then
        EndI = p波源 + ptNo - 1
        stepI = 1
    Else
        EndI = p波源 - ptNo + 1
        stepI = -1
    End If
    
    For i = p波源 To EndI Step stepI
        drwWave.AddNodes msoSegmentLine, msoEditingAuto, StartX + i * dX, StartY - WPX(i + 1)
    Next
    Set ShpWave = drwWave.ConvertToShape
    ShpWave.Line.Weight = 2
    ShpWave.Line.ForeColor.RGB = LineColor
    If IsMix = False Then
        Set Shp = TargetSlide.Shapes.Range(Array(SIndex(shp波源), SIndex(ShpWave))).Group
        Set GetWaveShape = Shp
    Else
        Set Shp = ShpWave
    End If
    Set GetWaveShape = ShpWave
End Function

Public Function 合成波(WaveCols As Variant) As Collection
    Dim arr(1 To ポイント数 + 1) As Currency
    Dim i As Long, j As Long
    For i = 1 To UBound(WaveCols)
        For j = 1 To ポイント数 + 1
            arr(j) = arr(j) + WaveCols(i)(j)
        Next
    Next
    
    Dim Col As Collection: Set Col = New Collection
    For i = 1 To ポイント数 + 1
        Col.Add arr(i)
    Next
    Set 合成波 = Col
    IsMix = True
End Function

Public Sub DeleteShp()
    If HasShape = True Then Shp.Delete
    HasShape = False
End Sub