線を引いて動かす ⑦ 複数の線を同時に動かす

ある理由から唐突に、Excelで線を引いて、それを動かしたくなった。
前回は、角数を指定するだけで正多角形を作成する関数を作成してみた。
infoment.hatenablog.com

今回は、複数の線をいっぺんに動かしてみよう。

複数の線をいっぺんに動かすためには、指定した全ての線を順番に、少しずつ少しずつ動かす必要がある。

そこで今回は（も？）、多段階配列（ジャグ配列）のお世話になる。
多段階配列とは、配列の要素が配列になっている配列を言う。ややこしい。
例えば、こんな感じだ。

Sub 多段階配列()
    Dim arr(1) As Variant
        arr(0) = Array(2, 3)
        arr(1) = Array(4, 5)
End Sub

配列arrの一つ一つの値が、配列になっている。だからたとえば、
arr(1)(1)は、arr(1)の値Array(4,5)の二つ目の値だから、
arr(1)(1)=5
となる（※0番から始まる）。

この理屈を用いて、こんな風にしてみた。

Sub MoveLine(ByVal start_position_array As Variant, _
             ByVal end_position_array As Variant, _
             Optional moving_times As Long = 30, _
             Optional delete_flag As Boolean = False)
    
    ReDim Preserve start_position_array(1 To UBound(start_position_array) - LBound(start_position_array) + 1)
    ReDim Preserve end_position_array(1 To UBound(end_position_array) - LBound(end_position_array) + 1)
    
    Dim LineNumber As Long
        LineNumber = UBound(start_position_array)
    
    ' 始点のx,y座標。
    Dim Sx() As Double: ReDim Sx(1 To LineNumber, moving_times)
    Dim Sy() As Double: ReDim Sy(1 To LineNumber, moving_times)
    ' 終点のx,y座標
    Dim Ex() As Double: ReDim Ex(1 To LineNumber, moving_times)
    Dim Ey() As Double: ReDim Ey(1 To LineNumber, moving_times)
    ' 一回当たりの移動量（始点）
    Dim dSx() As Double: ReDim dSx(1 To LineNumber)
    Dim dSy() As Double: ReDim dSy(1 To LineNumber)
    ' 一回当たりの移動量（終点）
    Dim dEx() As Double: ReDim dEx(1 To LineNumber)
    Dim dEy() As Double: ReDim dEy(1 To LineNumber)
    
    Dim myLine() As Shape: ReDim myLine(1 To LineNumber, moving_times)

    Dim i As Long
    Dim j As Long
        For i = 1 To LineNumber
    
            ' 初期値設定
            Sx(i, 0) = start_position_array(i)(0)
            Sy(i, 0) = start_position_array(i)(1)
            Ex(i, 0) = start_position_array(i)(2)
            Ey(i, 0) = start_position_array(i)(3)
        
        ' 移動後の座標設定。
            Sx(i, moving_times) = end_position_array(i)(0)
            Sy(i, moving_times) = end_position_array(i)(1)
            Ex(i, moving_times) = end_position_array(i)(2)
            Ey(i, moving_times) = end_position_array(i)(3)
        

            dSx(i) = (Sx(i, moving_times) - Sx(i, 0)) / moving_times
            dSy(i) = (Sy(i, moving_times) - Sy(i, 0)) / moving_times
    
            dEx(i) = (Ex(i, moving_times) - Ex(i, 0)) / moving_times
            dEy(i) = (Ey(i, moving_times) - Ey(i, 0)) / moving_times

            For j = 1 To moving_times - 1
                Sx(i, j) = Sx(i, j - 1) + dSx(i)
                Sy(i, j) = Sy(i, j - 1) + dSy(i)
                Ex(i, j) = Ex(i, j - 1) + dEx(i)
                Ey(i, j) = Ey(i, j - 1) + dEy(i)
            Next
        
        Next
    
        ' 設定した移動回数で変形。
        For j = 0 To moving_times
            For i = 1 To LineNumber
                Set myLine(i, j) = GetLine(Sx(i, j), Sy(i, j), Ex(i, j), Ey(i, j))
                If delete_flag Then
                    On Error Resume Next
                    myLine(i, j - 1).Delete
                End If
                Application.Wait [Now() + "00:00:00.01"]
            Next
        Next

End Sub

それでは、テストしてみよう。
今回は、正三角形～正八角形までを連続的に描画してみた。

Sub test()
    
    Dim j As Long
        For j = 3 To 8
            ActiveSheet.Shapes.SelectAll
            Selection.Delete
    
            DrawRegularPolygon j
        
            Dim Line() As Variant
            ReDim Line(1 To ActiveSheet.Shapes.Count)
            Dim i As Long
                For i = 1 To UBound(Line)
                    Set Line(i) = ActiveSheet.Shapes.Item(i)
                Next
                
            Dim StartArray() As Variant: ReDim StartArray(1 To UBound(Line))
            Dim EndArray() As Variant: ReDim EndArray(1 To UBound(Line))
                For i = 1 To UBound(Line)
                    StartArray(i) = GetPosisionArray(Line(i))
                Next
                
                For i = 1 To UBound(Line)
                    Select Case i
                        Case UBound(Line)
                            EndArray(i) = StartArray(1)
                        Case Else
                            EndArray(i) = StartArray(i + 1)
                    End Select
                Next
                
                ActiveSheet.Shapes.SelectAll
                Selection.Delete
                
                MoveLine StartArray, EndArray, 90 / j
        Next

End Sub

結果がこちら。

今回も、想定どおりに動かすことが出来た。
目標まで、あと少し。

次回に続きます。

参考まで。