たくさんのオートシェイプを指定座標まで動かす - Infomentのブログ～Excel VBA奮闘記～

昨日は一つのオートシェイプを、水中のミジンコみたいに動かしてみた。
infoment.hatenablog.com

今日は複数のオートシェイプを、同じように動かしてみる。
f:id:Infoment:20181203215829p:plain

といっても、やっていることは昨日と同じ。今回は、オートシェイプの数だけ配列を準備してみた。

Sub MoveTest()
    Dim i As Long
    For i = 1 To 100
        Call RandomMove
    Next
End Sub

Sub RandomMove()

    Dim myShape() As Shape
    Dim ShapeCount As Long
        ShapeCount = ActiveSheet.Shapes.Count
    ReDim myShape(1 To ShapeCount)
    
    ' 各オートシェイプの移動する軌跡
    Dim LFC() As LinearFunctionClass
    ReDim LFC(1 To ShapeCount)
    
    ' 移動前の位置
    Dim x1() As Double: ReDim x1(1 To ShapeCount)
    Dim y1() As Double: ReDim y1(1 To ShapeCount)
    
    ' 移動距離
    Dim dx() As Double: ReDim dx(1 To ShapeCount)
    Dim dy() As Double: ReDim dy(1 To ShapeCount)

    ' 移動後の位置
    Dim x2() As Double: ReDim x2(1 To ShapeCount)
    Dim y2() As Double: ReDim y2(1 To ShapeCount)
    
    Dim i As Long
        For i = 1 To ShapeCount
            Set myShape(i) = ActiveSheet.Shapes(i)
            Set LFC(i) = New LinearFunctionClass
            
            x1(i) = myShape(i).Left
            y1(i) = myShape(i).Top
            
            dx(i) = Rnd * 200 - 100
            If x1(i) >= 200 Then dx(i) = -50
            dy(i) = Rnd * 200 - 100
            If y1(i) >= 200 Then dy(i) = -50
            
            x2(i) = x1(i) + dx(i)
            y2(i) = y1(i) + dy(i)
            
            ' 始点と終点から、一次関数の式を求める。
            Dim myCoordinateSeq(1 To 2) As Variant
            myCoordinateSeq(1) = Array(x1(i), y1(i))
            myCoordinateSeq(2) = Array(x2(i), y2(i))
            
            LFC(i).CoordinateSeq = myCoordinateSeq
        Next
        
    ' 目的地に到達するまでの移動回数を設定。
    Dim iMax As Long
        iMax = 50
    
    ' 移動回数の一歩手前まで動かす。
    Dim x As Double
    Dim j As Long
        For i = 1 To iMax - 1
            For j = 1 To ShapeCount
                x = (6 * x1(j) + x2(j)) / 7
                myShape(j).Left = x
                myShape(j).Top = LFC(j).y(x)
                x1(j) = x
            Next
            Application.Wait [now()+"0:00:00.01"]
        Next
        
    ' 最後の一回で、目的地に到達。
    For i = 1 To ShapeCount
        myShape(i).Left = x2(i)
        myShape(i).Top = y2(i)
    Next
        
End Sub