Powerpoint VBAで波動シミュレーションを作成① - インストールレスプログラミング( ´ー`)

仕様
chemiphys.hateblo.jp
コレクションを利用してみたこと。
chemiphys.hateblo.jp

本格的に作り始めることにしました。
多忙の合間を縫ってでもやる。せっかくやりはじめましたし。。

まだ，いろんなことを実装できていませんが，とりあえずコレクションを使う，クラスモジュールを使う，合成波を実現する。

このくらいのことを実装してみました。
f:id:chemiphys:20170222223248g:plain

ちらついてるな　なんだろ(;´▽｀A``

変数は用意していますが，まだ機能していないものもたくさんです。やっとスタート。

標準モジュール

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

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

Public tCount As Long
Public TargetSlide As Slide

Sub test()
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

Do
    Wave1.DeleteShp
    Wave2.DeleteShp
    wave3.DeleteShp
    
    Wave1.SetWave = counter
    Wave2.SetWave(位相ずれ:=PI / 4) = counter
    wave3.SetWave = counter 'とりあえず
    
    Set retshp = Wave1.GetWaveShape
    Set retshp = Wave2.GetWaveShape(vbRed)
    
    Set MixWave(1) = Wave1.WaveCol
    Set MixWave(2) = Wave2.WaveCol
    wave3.WaveCol = wave3.合成波(MixWave)
    Set retshp = wave3.GetWaveShape(vbGreen)
    counter = counter + 1
    
    DoEvents
    Sleep 50
    
Loop

Stop

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 向き As Boolean
Private ptNomax As Long
Private ptNo As Long
Private Shp As Shape
Private HasShape As Boolean

Private Sub Class_Initialize()
    Set WPX = New Collection
    Do
        WPX.Add 0
    Loop Until WPX.Count = ポイント数
    HasShape = False
End Sub

Property Let SetWave(Optional ptNomax As Long = 160, Optional 波源X As Long = 0, _
        Optional p向き As Boolean = True, Optional 位相ずれ As Currency, _
        Optional 振幅倍率 As Currency = 1, Optional 速度倍率 As Currency = 1, cnt As Long)
    
    p波源 = 波源X
    If 波源X < 0 Then 波源X = 0
    If 波源X > 160 Then 波源X = 160
    WPCount = cnt
    ptNo = 0

    Dim Y As Currency
    Dim i As Long
    For i = 1 To 2 * WPCount
        Y = A * Sin(i * dP - 位相ずれ)
        ptNo = ptNo + 1
        If ptNo > ptNomax Then ptNo = ptNomax
        
        If p向き = True Then
            WPX.Add Y, before:=p波源 + 1
            WPX.Remove WPX.Count
        Else
            WPX.Add Y, after:=p波源 + 1
            WPX.Remove 1
        End If
    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
    Set shp波源 = TargetSlide.Shapes.AddShape(msoShapeOval, StartX + p波源 * 5 - 7.5, StartY - WPX(1) - 7.5, 15, 15)
    shp波源.Fill.ForeColor.RGB = LineColor
    shp波源.Fill.Visible = msoTrue
    shp波源.TextFrame.TextRange = " "
    HasShape = True
    
    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, StartY - WPX(1))
    Dim i As Long
    For i = 2 To ptNo
        drwWave.AddNodes msoSegmentLine, msoEditingAuto, StartX + (i - 1) * dX, StartY - WPX(i)
    Next
    Set ShpWave = drwWave.ConvertToShape
    ShpWave.Line.Weight = 2
    ShpWave.Line.ForeColor.RGB = LineColor
    
    Set Shp = TargetSlide.Shapes.Range(Array(SIndex(shp波源), SIndex(ShpWave))).Group
    Set GetWaveShape = Shp
End Function

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

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