たくさんのオートシェイプを指定座標まで動かすクラス

昨日は複数のオートシェイプを、水中のミジンコみたいに動かしてみた。
infoment.hatenablog.com
今日は、昨日作成した箇所のクラスモジュール化に挑戦する。

今回の挑戦は、力不足の悲しさか、混迷を極めた。理由は単純で、目的地が毎回変わるようなコードに改編してしまったから。その場で指定回数プルプル震えた後、目的地までワープするという奇っ怪なものが出来上がってしまった。

その後、何とか力業で昨日の状況まで再現した。それにしても、標準モジュールをクラスモジュールに移植するとき、皆さんはどうされているのだろう。

1. そもそも、そんなことしない。
2. 一つずつ、機能別に移植していく。

など色々あると思うが、私の中では未だ確立しきれていない。

ということで、今回作成したのがこちら。

クラスモジュール（MovingShapeClass）

Option Explicit

Private Sub Class_Initialize()
    Dim iMax As Long
        iMax = 30
        
    Dim x_start_seq() As Double: ReDim x_start_seq(1 To ShapeCount)
    Dim y_start_seq() As Double: ReDim y_start_seq(1 To ShapeCount)
    Dim x_end_seq() As Double: ReDim x_end_seq(1 To ShapeCount)
    Dim y_end_seq() As Double: 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
    
    Dim x As Double
    Dim j As Long
        For i = 1 To iMax - 1
            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.01"]
        Next
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 * 200 - 100
    If x_start(shape_index) >= 200 Then dx = -50
End Function

Public Function dy(shape_index As Long) As Double
    dy = Rnd * 200 - 100
    If y_start(shape_index) >= 200 Then dy = -50
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

標準モジュール

ほとんどクラスモジュールに渡してしまったので、こちらは実にアッサリとしたものに。

Sub MoveTest()
    Dim MSC As MovingShapeClass
    Dim i As Long
    For i = 1 To 30
        Set MSC = New MovingShapeClass
    Next
End Sub

結果は、昨日とほぼ同じ。でも、何だかちょっと、速くなった気がする。

明日はこれを、本当にやりたかった動きに改修します。

参考まで。