カレンダー切り替えに付す視覚効果 - Infomentのブログ～Excel VBA奮闘記～

昨日は複数のオートシェイプを、水中のミジンコのように動かしてみた。
infoment.hatenablog.com
しかし本当に作りたいのは、アクアリウムではなく、別のものだったりする。
f:id:Infoment:20181205221737p:plain

昨日まで作成していたのは、ランダムに進行方向と距離を決めて移動する仕掛け。しかし本当は、行った後に、元の位置まで戻って欲しい。
そこでクラスモジュールに、

MoveForword
MoveBackword

を設けて、ちゃんとスタート位置に帰ってこられるようにした。

クラスモジュール（MovingShapeClass）

Option Explicit

    Dim x_start_seq() As Double
    Dim y_start_seq() As Double
    Dim x_end_seq() As Double
    Dim y_end_seq() As Double
    Public iMax As Long
    Public MoveRange As Long
    
    Enum EndIndex
        vbStart = 1
        vbEnd
    End Enum

Private Sub Class_Initialize()
    
    If iMax = 0 Then iMax = 30
    If MoveRange = 0 Then MoveRange = 200
    
    ReDim x_start_seq(1 To ShapeCount)
    ReDim y_start_seq(1 To ShapeCount)
    ReDim x_end_seq(1 To ShapeCount)
    ReDim y_end_seq(1 To ShapeCount)
    
    Dim i As Long
        For i = 1 To ShapeCount
            x_start_seq(i) = x_start(i)
            y_start_seq(i) = y_start(i)
            x_end_seq(i) = x_end(i)
            y_end_seq(i) = y_end(i)
        Next
End Sub

Public Sub MoveForward()
    Dim x As Double
    Dim i As Long
    Dim j As Long
        For i = 1 To iMax
            For j = 1 To ShapeCount
                x = (6 * myShape(j).Left + x_end_seq(j)) / 7
                myShape(j).Left = x
                myShape(j).Top = y(x, x_start_seq(j), y_start_seq(j), x_end_seq(j), y_end_seq(j))
            Next
            Application.Wait [now()+"0:00:00.001"]
        Next
End Sub

Public Sub MoveBackward()
    Dim x As Double
    Dim i As Long
    Dim j As Long
        For i = 1 To iMax
            For j = 1 To ShapeCount
                x = (6 * myShape(j).Left + x_start_seq(j)) / 7
                myShape(j).Left = x
                myShape(j).Top = y(x, x_end_seq(j), y_end_seq(j), x_start_seq(j), y_start_seq(j))
            Next
            Application.Wait [now()+"0:00:00.01"]
        Next
End Sub

Public Sub SetEnd(end_index As EndIndex)
    Dim i As Long
    Select Case end_index
        Case vbStart
            For i = 1 To ShapeCount
                myShape(i).Left = x_start_seq(i)
                myShape(i).Top = y_start_seq(i)
            Next
        Case vbEnd
            For i = 1 To ShapeCount
                myShape(i).Left = x_end_seq(i)
                myShape(i).Top = y_end_seq(i)
            Next
    End Select
End Sub
Public Property Get ShapeCount() As Long
    ShapeCount = ActiveSheet.Shapes.Count
End Property

Public Function myShape() As Variant
    Dim i As Long
    Dim s() As Variant
    ReDim s(1 To ShapeCount)
        For i = 1 To ShapeCount
            Set s(i) = ActiveSheet.Shapes(i)
        Next
        myShape = s
End Function

Public Function x_start(shape_index As Long) As Double
    x_start = myShape(shape_index).Left
End Function

Public Function y_start(shape_index As Long) As Double
    y_start = myShape(shape_index).Top
End Function

Public Function dx(shape_index As Long) As Double
    dx = Rnd * MoveRange - MoveRange / 2
    If x_start(shape_index) >= MoveRange Then dx = -MoveRange / 4
End Function

Public Function dy(shape_index As Long) As Double
    dy = Rnd * MoveRange - MoveRange / 2
    If y_start(shape_index) >= MoveRange Then dy = -MoveRange / 4
End Function

Public Function x_end(shape_index As Long) As Double
    x_end = x_start(shape_index) + dx(shape_index)
End Function

Public Function y_end(shape_index As Long) As Double
    y_end = y_start(shape_index) + dy(shape_index)
End Function

Public Function y(x As Double, x_start As Double, y_start As Double, x_end As Double, y_end As Double) As Double
    Dim LFC As LinearFunctionClass
    Set LFC = New LinearFunctionClass
    
    Dim myCoordinateSeq(1 To 2) As Variant
    myCoordinateSeq(1) = Array(x_start, y_start)
    myCoordinateSeq(2) = Array(x_end, y_end)
    
    LFC.CoordinateSeq = myCoordinateSeq
    y = LFC.y(x)
End Function