等分された円周上の点を線で結んでみる ④ 色などを変えてみる

先日から、等分された円周上の点を線で結んで、きれいな模様を作成することに挑戦している。
infoment.hatenablog.com

今日も、昨日の続きから。

昨日までは、単色での描画だった。

そこで今回、以下の三つを設けてみた。

1. ランダム色
2. 濃淡モード
3. 線種

１．ランダム色

文字通り、素数毎に色をランダムに変える。こんな感じで。

２．濃淡モード

素数の数が小さいほど外周部に偏って、塗りつぶされたように濃くなる。
そこで、素数が小さいほど線を薄くしてみた。こんな感じで。

３．線種

点線や一点鎖線、二点鎖線などを選べるようにした。こんな感じだ。

これはこれで、不思議な趣があってよい。

４．複合

上記の３つを組み合わせてみると、こうなる。

クラスモジュールの全文がこちら。継ぎ足しで作ったので、変数名が英文と和文でゴチャマゼになってしまった。

クラスモジュール（Mandara）

Option Explicit
Enum 座標軸名
    x座標
    y座標
End Enum

Public 分割数 As Long
Public 旋回中心 As Variant
Public 旋回半径 As Double
Public 濃淡モード As Boolean
Public ランダム色 As Boolean
Public 線種 As MsoLineDashStyle
Public 線幅 As Double

Private Sub Class_Initialize()
    分割数 = 30
    旋回中心 = Array(500, 500)
    旋回半径 = 200
    濃淡モード = False
    ランダム色 = False
    線種 = msoLineSolid
    線幅 = 0.25
End Sub

Public Sub Reset()
    ' 元々書いてある線を削除。
    On Error Resume Next
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
End Sub

Public Property Get 各座標取得() As Variant
    Dim arr() As Variant
    ReDim arr(1 To 分割数 + 1)
    Dim x As Double
    Dim y As Double
    Dim i As Long
    Dim θ As Double
        θ = 2 * WorksheetFunction.Pi / 分割数
        For i = 1 To 分割数
            x = 旋回中心(x座標) + 旋回半径 * Sin(i * θ)
            y = 旋回中心(y座標) - 旋回半径 * (1 - Cos(i * θ))
            arr(i) = Array(x, y)
        Next
        arr(分割数 + 1) = arr(1)
    
        各座標取得 = arr
End Property

Sub ConnectAllPoint(Optional wait_flag As Boolean = False)
    Dim i As Long
    Dim j As Long
        For i = 1 To 分割数
            For j = 1 To 分割数 - i
                ActiveSheet.Shapes.AddConnector msoConnectorStraight, _
                                                各座標(i)(x座標), 各座標(i)(y座標), _
                                                各座標(i + j)(x座標), 各座標(i + j)(y座標)
            Next
            If wait_flag Then
                Application.Wait [Now() + "00:00:00.1"]
            End If
        Next
End Sub

Sub PrimeMandara(prime_number As Long, _
        Optional wait_flag As Boolean = False)
    Dim 始点 As Long: 始点 = 1
    Dim 終点 As Long: 終点 = 1
    Dim 各座標 As Variant
        各座標 = 各座標取得
    Dim Shape As Shape
    
    Dim R As Long, G As Long, B As Long
        R = WorksheetFunction.RandBetween(0, 255)
        G = WorksheetFunction.RandBetween(0, 255)
        B = WorksheetFunction.RandBetween(0, 255)
    
        Do
            始点 = 終点
            終点 = ((始点 + prime_number - 1) Mod 分割数) + 1
    
            Set Shape = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
                                                         各座標(始点)(x座標), 各座標(始点)(y座標), _
                                                         各座標(終点)(x座標), 各座標(終点)(y座標))
            If 濃淡モード Then
                Shape.Line.ForeColor.TintAndShade = 0.5 - 1.5 * (prime_number - 3) / (分割数 - 3)
            End If
            Shape.Line.DashStyle = 線種
            
            If ランダム色 Then
                Shape.Line.ForeColor.RGB = RGB(R, G, B)
            End If
            
            If wait_flag Then
                Application.Wait [Now() + "00:00:00.1"]
            End If
            
            If 終点 = 1 Then Exit Do
        Loop
End Sub

Sub RegularPrimeMandara(Optional division_count As Long = 64, _
                        Optional reset_flag As Boolean = True)
    Dim Max As Long
    
    ' 描画に使用する最初の素数。
    Dim num As Long: num = 3
        If reset_flag Then
            Call Reset
        End If
    
    ' 分割数が４以下の場合、強制的に５とする。
    ' ※この場合、５つの頂点を持つ星が描画される。
        If division_count <= 4 Then
            division_count = 5
        End If
    
    ' 分割点を飛ばす個数（素数）がMaxを超えた時点で、処理を中断する。
    ' Maxは、最大値の半分（小数点切り上げ）とする。
        分割数 = division_count
        Max = WorksheetFunction.RoundUp(分割数 / 2, 0)
        
        Do
            PrimeMandara num
            num = NextPrimeNumber(num)
            
            If num >= Max Then
                Exit Do
            End If
        Loop
End Sub

' numより大きい最初の素数を返す。
Function NextPrimeNumber(num As Long) As Long
    Do
        num = num + 1
        If 素数判定(num) Then
            NextPrimeNumber = num
            Exit Function
        End If
    Loop
End Function

' numが素数ならば、Trueを返す。
' 素数でないならば、Falseを返す。
Function 素数判定(num As Long) As Boolean
    Dim i As Long
        If num <= 1 Then
            素数判定 = False
        ElseIf num = 2 Then
            素数判定 = True
        Else
            For i = 2 To WorksheetFunction.RoundUp(num ^ 0.5, 0)
                If num Mod i = 0 Then
                    素数判定 = False
                    Exit Function
                End If
            Next
            素数判定 = True
        End If
End Function

テスト用のコードがこちら。

Sub test()
    With New Mandara
        .濃淡モード = True
        .ランダム色 = True
        .線種 = msoLineDashDot
        
        .RegularPrimeMandara
    End With
End Sub

参考まで。