Duplicateで旋回運動の続き：放射+分身+残像（完成）

昨日は、円を旋回運動させるマクロにおいて、指定数の分身を指定数の残像を残すことに挑戦した。
infoment.hatenablog.com
結果、何とか思った通りの動きをさせることが出来た。

ただ、円周上に突然円が登場するので、唐突感が否めない。そこで今回は更に動作を追加して、一連の締めくくりとする。

まず、昨日のテスト結果だが、分身が円周上にバラバラに配置されているように見える。

その辺り考慮せずにテストしたため、当たり前と言えば、当たり前。

思うに、仕掛けを作るのも大変だが、その動きを調整するのも同じか、それ以上に難しい。ちなみに、ある程度調整した結果が↓こちら。

今回は更に、中心から円周上に放射状に配置させてみた。

クラスモジュール（DuplicateShapeClass）

Option Explicit
Public Enum AngleType
    myDeg   ' ※１回転で360°
    myRad   ' ※１回転で2π
End Enum

Public x0 As Double
Public y0 As Double
Public RotateRadius As Double
Public RotateShapeRadius As Double
Public PhantomNumber As Long

Dim StartAngles() As Double

Private Property Get π() As Double
    π = WorksheetFunction.Pi
End Property

Public Sub GetStartAngle(angle_value As Double, angle_type As AngleType)
    If PhantomNumber = 0 Then PhantomNumber = 1
    ReDim StartAngles(PhantomNumber - 1)

    Dim i As Long
    For i = 0 To PhantomNumber - 1
        Select Case angle_type
            Case myDeg
                StartAngles(i) = (angle_value + 360 / PhantomNumber * i) * π / 180
            Case myRad
                StartAngles(i) = angle_value + 2 * π * i / PhantomNumber
        End Select
    Next
End Sub

Private Function SetStartShape(phantom_index As Long) As Shape
    Dim r As Double
        r = RotateShapeRadius
        If r = 0 Then r = 30
    Dim x As Double
    Dim y As Double
        x = x0 - RotateRadius * Cos(StartAngles(phantom_index)) + r / 2
        y = y0 - RotateRadius * Sin(StartAngles(phantom_index)) + r / 2
        Set SetStartShape = ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, r, r)
End Function

Sub RotateShape(Optional rotation_number As Double = 1, _
                Optional rotation_angle As Double = 5, _
                Optional after_image As Long = 10)

    ' 分身の数を確認。なければ１（つまり本体のみ）をセット。
    If PhantomNumber = 0 Then PhantomNumber = 1
    ' 半径が未設定の場合、200をセット。
    If RotateRadius = 0 Then RotateRadius = 200
    ' 残像の数を、設定値×分身の数に再設定。
    after_image = after_image * PhantomNumber

    ' 旋回数と旋回角度、分身の数から、ループ回数を決定。
    Dim iMax As Long
        iMax = (rotation_number * 360 / rotation_angle) * PhantomNumber
    
    ' 配置する円を格納するための配列。
    Dim Shapes() As Shape
    ReDim Shapes(iMax)
    
    ' 移動前の、原点から見た移動物のｘｙ座標における角度。
    Dim θ1() As Double
    ReDim θ1(PhantomNumber)
    ' 移動後の、原点から見た移動物のｘｙ座標における角度。
    Dim θ2() As Double
    ReDim θ2(PhantomNumber)
    
    Dim i As Long
    Dim j As Long
    
    ' 最初に配置される円の座標。
    Dim x() As Double: ReDim x(PhantomNumber - 1)
    Dim y() As Double: ReDim y(PhantomNumber - 1)
    
    ' 座標を取得するために、一旦円を配置する。
        For i = 0 To PhantomNumber - 1
            Set Shapes(i) = SetStartShape(i)
            x(i) = Shapes(i).Left
            y(i) = Shapes(i).Top
            Shapes(i).Delete
        Next
    ' 放射状に展開する円を格納する変数。
    Dim TempShape As Shape
    Dim r As Double: r = RotateShapeRadius
    ' 放射状に展開する円の、中心から見た距離。
    Dim dx As Double
    Dim dy As Double
    
    ' 放射状に展開した円を格納するコレクション。
    ' ※円を消去するために使用。
    Dim col As Collection
    Set col = New Collection
    
        ' 分身の数だけ、中央から円を放射状に展開する。
        For j = 1 To 10
            For i = 0 To PhantomNumber - 1
                dx = (x(i) - x0 - r / 2) / 10 * j
                dy = (y(i) - y0 - r / 2) / 10 * j
                Set TempShape = ActiveSheet.Shapes.AddShape(msoShapeOval, x0 + r / 2 + dx, y0 + r / 2 + dy, r, r)
                    TempShape.ShapeStyle = msoShapeStylePreset37
                Application.Wait [now()+"0:00:00.01"]
                col.Add TempShape
            Next
        Next
    
    ' 放射状に展開した円を、配置した順に削除する。
    Dim c As Variant
        For Each c In col
            c.Delete
            Application.Wait [now()+"0:00:00.01"]
        Next
    
    ' ↓ここからは、円周上に配置された円を回転させる部分。
    ' 円周上に、分身を含めた円を配置する。
        For i = 0 To PhantomNumber - 1
            Set Shapes(i) = SetStartShape(i)
                Shapes(i).ShapeStyle = msoShapeStylePreset37
            ' 移動前の円の角度。
            θ1(i) = StartAngles(i)
            ' 移動後の円の角度。
            θ2(i) = θ1(i) - rotation_angle * π / 180
        Next
        
    ' 円の配置と分身の透過度変更、消去。
    Dim PhantomIndex As Long
        For i = PhantomNumber To iMax + after_image
            If i <= iMax Then
                ' 移動後の円の配置。
                Set Shapes(i) = Shapes(i - PhantomNumber).Duplicate
                ' 移動前の円の透過度を変更。
                Shapes(i - PhantomNumber).Fill.Transparency = 0.8
                
                ' ループカウンターから、何番目の分身かを求める。
                PhantomIndex = i Mod PhantomNumber
                
                ' 移動前の円と移動後の円の座標の差。
                dx = RotateRadius * (Cos(θ2(PhantomIndex)) - Cos(θ1(PhantomIndex)))
                dy = RotateRadius * (Sin(θ2(PhantomIndex)) - Sin(θ1(PhantomIndex)))
            
                ' 複製した円を、移動後の円の位置に移動させる。
                Shapes(i).Left = Shapes(i - PhantomNumber).Left - dx
                Shapes(i).Top = Shapes(i - PhantomNumber).Top - dy
                
                ' 次の移動後の角度を求める。
                θ1(PhantomIndex) = θ2(PhantomIndex)
                θ2(PhantomIndex) = θ1(PhantomIndex) - rotation_angle * π / 180
            End If
            
            ' 回り切った後、消し残りの残像を削除する。
            If i >= after_image Then
                Shapes(i - after_image).Delete
            End If
            Application.Wait [now()+"0:00:00.01"]
        Next

End Sub

標準モジュール

Sub RotateTest()
    Dim DSC As DuplicateShapeClass
    Set DSC = New DuplicateShapeClass
        DSC.x0 = 400
        DSC.y0 = 300
        DSC.RotateRadius = 200
        DSC.RotateShapeRadius = 30

        Dim i As Long
        For i = 1 To 6
            DSC.PhantomNumber = i
            Call DSC.GetStartAngle(90, myDeg)
            Call DSC.RotateShape(rotation_number:=5 / i, _
                                 rotation_angle:=60 / i, _
                                 after_image:=30 / i)
        Next
End Sub

その結果、このようになった。

それなりに、それっぽくなったと思う。
しかし、個人的には面白かったが、このブログが目指す「仕事を早く終わらせて家に帰る」という点において、直接の役には立たない。

ということで、今回のシリーズは、これでおしまい。

参考まで。