Duplicateで旋回運動の続き：汎用化に挑戦 - Infomentのブログ～Excel VBA奮闘記～

昨日はオートシェイプをグルグルと回して遊んでいたら、実は旋回中心と旋回半径が可変になっていることに気づいた。
infoment.hatenablog.com
これはイカン。すぐに直さないと。
f:id:Infoment:20190123220659p:plain

まず、旋回中心と半径が可変にならないよう、固定値にした。
今までは、以下のとおり。

任意のポイントに円を描画
任意の旋回中心をあたえる
旋回中心と円の位置関係から角度を求める
指定角度毎に旋回させる

これだとまず、累積誤差が発生しやすいのではないかと考えた。
そこで、以下の方式に変更した。

任意の旋回中心を与える
任意の旋回半径と、開始角度を与える
指定角度毎に旋回させる

ついでに、これらを引数にした。結果がこちら（紆余曲折が、ありました）。

クラスモジュール（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

Dim StartAngle As Double

Public Sub GetStartAngle(angle_value As Double, angle_type As AngleType)
    Select Case angle_type
        Case myDeg
            StartAngle = angle_value * WorksheetFunction.Pi / 180
        Case myRad
            StartAngle = angle_value
    End Select
End Sub

Private Function SetStartShape() 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(StartAngle) + r / 2
        y = y0 - RotateRadius * Sin(StartAngle) + r / 2

        
        Set SetStartShape = ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, r, r)
End Function

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

    Dim iMax As Long
        iMax = rotation_number * 360 / rotation_angle
    Dim Shapes() As Shape
    ReDim Shapes(iMax)
    
    Set Shapes(0) = SetStartShape
        Shapes(0).ShapeStyle = msoShapeStylePreset37
    
    Dim x1 As Double: x1 = Shapes(0).Left
    Dim y1 As Double: y1 = Shapes(0).Top
        
    Dim θ1 As Double
        θ1 = StartAngle

        If RotateRadius = 0 Then
            RotateRadius = 200
        End If

    Dim θ2 As Double
        θ2 = θ1 - rotation_angle * WorksheetFunction.Pi / 180
        
    Dim dx As Double
    Dim dy As Double
    
    Dim i As Long
        For i = 1 To iMax + after_image
            If i <= iMax Then
                Application.Wait [now()+"0:00:00.01"]
                Set Shapes(i) = Shapes(i - 1).Duplicate
                Shapes(i - 1).Fill.Transparency = 0.8
                
                dx = RotateRadius * (Cos(θ2) - Cos(θ1))
                dy = RotateRadius * (Sin(θ2) - Sin(θ1))
            
                Shapes(i).Left = Shapes(i - 1).Left + dx
                Shapes(i).Top = Shapes(i - 1).Top + dy
                
                θ1 = θ2
                θ2 = θ1 - rotation_angle * WorksheetFunction.Pi / 180
                
            End If
            
            If i >= after_image Then
                Application.Wait [now()+"0:00:00.01"]
                Shapes(i - after_image).Delete
            End If
        Next

End Sub

一回の旋回角度を変えても、旋回半径と旋回中心が変化しないことを確認するために、こんな風に描画してみた。

標準モジュール

Sub RotateTest()

    Dim DSC As DuplicateShapeClass
    Set DSC = New DuplicateShapeClass
    
        DSC.x0 = 400
        DSC.y0 = 700
        DSC.RotateRadius = 200
        DSC.RotateShapeRadius = 30
        Call DSC.GetStartAngle(90, myDeg)
        
    Dim i As Double
        For i = 5 To 30 Step 2.5
            Call DSC.RotateShape(rotation_number:=1, _
                                 rotation_angle:=i, _
                                 after_image:=10)
        Next

End Sub