マンデルブロ集合（mandel brot set）

Option ExplicitOption Explicit

'-------------------------------------
' マンデル・ブロー集合
'
' 複素数の数列　Zn+1=Zn^2+C
'
' 　が発散する回数を複素平面での色として求める
'
' 　Z = X+iY 　C=a+ib （i 虚数単位）として
'
' 　実数　Xn+1 = Xn^2 - Yn^2 + a
' 　虚数　Yn+1 = 2*Xn*Yn + b
'
' 　の数列を計算する
'
'--------------------------------------

Dim Rng As Range        'セル範囲オブジェクト
Dim Selected As Range   '選択されている範囲

Dim 中止 As Boolean     '中止フラグ

'---------------------
' 初期値
'---------------------

    
'計算範囲
Const INIT_AMAX = 0.9   '実数軸最大
Const INIT_AMIN = -2.3  '　　最小
Const INIT_BMAX = 1.2   '虚数軸最大
Const INIT_BMIN = -1.2  '　　最小

'セル範囲
Dim CMax As Integer        '列最大
Dim CMin As Integer        '　最小
Dim RMax As Integer        '行最大
Dim RMin As Integer        '　最小
Dim RC_ratio As Double     '比

Dim xmax As Double, xmin As Double
Dim ymax As Double, ymin As Double

Dim cs As Integer, ce As Integer
Dim rs As Integer, re As Integer


Dim max_cnt As Long         '指定反復計算最大回数
Const MAX_CNT_LIMIT = 5000  '同上限

'------------------------------------
' 履歴
'------------------------------------
Private Type TYPE_HISTORY
    xmin As Double
    xmax As Double
    ymin As Double
    ymax As Double
    max_cnt As Long
    rs As Integer
    re As Integer
    cs As Integer
    ce As Integer
End Type

Dim History(1) As TYPE_HISTORY  '履歴

'////////////////////////////////////////////
'
' イベント処理
'
'////////////////////////////////////////////

Private Sub cmdStop_Click()     '中止
    中止 = True
End Sub


Private Sub cmdInit_Click() ' 初期状態に戻す
    Call Init                       '初期化
    Rng.Interior.Pattern = xlNone   'クリア
    Set Selected = Nothing              '未選択状態
    Range("XY").Value = GetXY       '計算範囲
    Range("MAG").Value = GetMag     '拡大率表示
    Call Go                         '開始
End Sub


Private Sub cmdReCal_Click()  '再計算
    Call Go
End Sub


Private Sub cmdBack_Click()
'
' 戻る
'
    Set Rng = Range("DATA")                 '描画域
    With History(1)
        xmin = .xmin: xmax = .xmax: ymin = .ymin: ymax = .ymax
        max_cnt = .max_cnt
        rs = .rs: re = .re: cs = .cs: ce = .ce
    End With
    cmbCalCount.Value = max_cnt
    cmdBack.Enabled = False

    
    Call Go '作成開始
    
    Range("DATA").Range("A1").Select 'セル選択

End Sub


Private Sub cmdMagnify_Click()
'
' 選択範囲を拡大
'
    Dim xs As Double, xe As Double
    Dim ys As Double, ye As Double
    Dim Lc As Double, Lr As Double
    Dim Lx As Double, Ly As Double

    Set Rng = Range("DATA")                 '描画域
    Rng.Interior.Pattern = xlNone   'クリア
    
    '-------------------------
    ' 選択範囲チェック
    '-------------------------
    Dim blErr As Boolean
    blErr = False
    If Selected Is Nothing Then '未選択
        blErr = True
    ElseIf Selected.Rows.Count + Selected.Columns.Count < 4 Then    '範囲不足
        blErr = True
    End If
    If blErr Then
        MsgBox "拡大範囲を選択して下さい！"
        Exit Sub
    End If
    '-------------------------
   
    If xmax = 0 And xmin = 0 Then Call Init    '範囲選択−未

    Lc = CMax - CMin + 1
    Lr = RMax - RMin + 1
    Lx = xmax - xmin
    Ly = ymax - ymin
    
    cs = Selected.Column - CMin             '選択セル 列開始
    ce = cs + Selected.Columns.Count - 1    '         列終わり
    
    rs = Selected.Row - RMin                '選択セル 行開始
    re = rs + (ce - cs) * RC_ratio          '　　　　 列幅にあわせる
    
    '------------------------------------
    ' 履歴
    '------------------------------------
    With History(1)
        .xmin = xmin: .xmax = xmax: .ymin = ymin: .ymax = ymax
        .max_cnt = max_cnt
        .rs = rs: .re = re: .cs = cs: .ce = ce
    End With
    '------------------------------------

    xmax = xmin + Lx * (ce - 1) / (Lc - 1)
    xmin = xmin + Lx * (cs - 1) / (Lc - 1)
    
    ymin = ymin + Ly * (rs - 1) / (Lr - 1)
    ymax = ymin + (xmax - xmin) * (INIT_BMAX - INIT_BMIN) / (INIT_AMAX - INIT_AMIN)
    

    cmdBack.Enabled = False  '「戻る」ボタン無効

    Call Go '作成開始
    
    cmdBack.Enabled = True  '「戻る」ボタン有効
    
End Sub


Private Sub cmdDetail_Click()
'
' 選択域を細密表示
'
    中止 = False

    With Selected
        Go_Sub .Row, _
               .Row + .Rows.Count - 1, _
               .Column, _
               .Column + .Columns.Count - 1, _
               1 '解像度に応じて
        .Select
    End With
    
End Sub


Private Sub Worksheet_Activate()    'ワークシートがアクティブになった
    Call Init   '初期値
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)    '選択範囲が変更された
    
    Dim Data As Range

    Set Data = Range("DATA")
    Set Selected = Intersect(Target, Data)

    Dim Rng As Range
    Set Rng = Intersect(Target, Data)
    Application.StatusBar = GetMag(Rng) & "    " & _
                            GetSel(Rng) & "     " & _
                            GetXY(Rng)   '計算範囲、拡大率表示

End Sub

'////////////////////////////////////////////
'
' 内部関数
'
'////////////////////////////////////////////

Private Sub Init()          '初期値設定
    Set Rng = Range("DATA")                 '描画域
    RMin = 1: RMax = Rng.Rows.Count         'セル行−開始／終了
    CMin = 1: CMax = Rng.Columns.Count      '　　列−開始／終了
    RC_ratio = (RMax - RMin) / (CMax - CMin) '行列数比
    xmax = INIT_AMAX: xmin = INIT_AMIN      '描画範囲　x軸　開始／終了
    ymax = INIT_BMAX: ymin = INIT_BMIN      '　　　　　y軸
End Sub


Private Sub Go(Optional Stp As Integer = 1)

    Dim St As Date
    Range("所要時間") = "描画中"
    St = Now()
    
    Set Rng = Range("DATA")                 '描画域
    Range("SELCEL").Value = GetSel(Selected)  '選択範囲
    Range("A2").Select      '描画エリアを未選択状態にする
    
    中止 = False

    Go_Sub RMin, RMax, CMin, CMax, 2 * lstResolution.ListIndex + 1 '解像度に応じて

    Range("所要時間") = Now() - St
    
End Sub

Private Sub Go_Sub(rrmin As Integer, rrmax As Integer, _
                   ccmin As Integer, ccmax As Integer, _
                   Optional Stp As Integer = 1)
'
' 作成開始
'
    Dim v As Double
    
    Dim r As Integer, c As Integer  '行、列
    Dim rrs As Integer, rre As Integer
    Dim ccs As Integer, cce As Integer
    
    Dim x As Double, y As Double

    Dim blColor As Boolean  '着色−描画時に有効
    Dim intDrawRows As Integer  '一回の描画行数

    Dim Color As Long

    
    cmdStop.Enabled = True  '中止ボタンを有効

    If xmax = 0 And xmin = 0 Then Call Init     '計算範囲未設定→初期化
    
    '---------------------------
    ' 可変値
    '---------------------------
    intDrawRows = Int(Range("描画行数"))    '一回の描画行数
    blColor = CBool(chkColor.Value)         '着色
    max_cnt = Val(cmbCalCount.Value)        '反復計算回数

    Range("MAG0").Value = GetMag0       '拡大率（前回比）
    Range("MAG").Value = GetMag         '拡大率

    Range("XY").Value = GetXY                   '計算範囲
    
    MyWait 100, 中止
    
    '--------------------------------------
    ' 解像度に応じて計算中心位置を決定
    '--------------------------------------
    Dim Span As Integer
    Span = (Stp + 1) / 2 - 1
    rrs = rrmin + Span: rre = rrmax - Span
    ccs = ccmin + Span: cce = ccmax - Span

    If intDrawRows > 1 Then Application.ScreenUpdating = False
    
    For r = rrs To rre - Span Step Stp

        For c = ccs To cce - Span Step Stp
        
            x = xmin + (xmax - xmin) * (c - CMin + 1) / (CMax - CMin + 1)
            y = ymin + (ymax - ymin) * (r - RMin + 1) / (RMax - RMin + 1)
            v = CalDivCount(0, 0, x, y, max_cnt)

            '-------------------------------------
            ' 着色処理
            '-------------------------------------
            Color = 0   '黒
            If v < max_cnt Then '反復計算回数最大値より小さい場合
            
                If blColor Then '着色要？
                    Dim ColorBase As Long
                    ColorBase = RGB(100, 100, 100)
                    Color = ColorBase + (&HFFFFFF - ColorBase) * v / MAX_CNT_LIMIT   'カラー
                Else
                    v = 255 * (1 - v / max_cnt)             '白黒
                    Color = RGB(v, v, v)
                End If
            
            End If
            
,            Rng.Range(Cells(r - Span, c - Span), Cells(r + Span, c + Span)).Interior.Color = Color
            '--------------------------------------

        Next c

        If (intDrawRows > 1) And (r Mod intDrawRows) = 0 Then
            Range("所要時間") = Range("所要時間") & "."
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
        End If
        
        If 中止 Then Exit For
        Application.StatusBar = (r & "/" & RMax)    'ステータスバーに進行状況表示
        
        DoEvents

    Next r
    
    If intDrawRows > 1 Then Application.ScreenUpdating = True
    
    cmdStop.Enabled = False '中止ボタンを無効

End Sub

１６，４７，７９−８３，９２　高速描画用処理
　　行数に１より大きい値を指定されている場合、画面更新をオフ（Application.ScreenUpdating=False）とし、
　　複数行を描画後に画面更新をオン（Application.ScreenUpdating=True）とする。
　　これにより、描画速度が数倍に上がる。

Private Function GetSel(Optional Target As Range) As String
'
' 選択セル情報取得
'
    Dim r0 As Integer, c0 As Integer, r As Integer, c As Integer
    Dim Data As Range
    
    Set Data = Range("DATA")
    
    With Target
        
        If Target Is Nothing Then
            
            cmdMagnify.Enabled = False  '選択域拡大　有効
            cmdDetail.Enabled = False   '　　　細密
            
            GetSel = RMin & "," & CMin & " - " & RMax & "," & CMax
        Else
            
            cmdMagnify.Enabled = True
            cmdDetail.Enabled = True
            
            r0 = Data.Row - 1: c0 = Data.Column - 1
            r = .Row - r0: c = .Column - c0
            GetSel = r & "," & c & " - " & _
                               (r + .Rows.Count - 1) & "," & (c + .Columns.Count - 1)   '選択セル
        End If
        
    End With
    
End Function


Private Function GetMag0(Optional Target As Range) As String
'
' 拡大率（前回比）
'
    Dim v As Double
    v = 0
    With History(1)
        If (.xmax <> .xmin) And (xmax <> xmin) Then
            v = (.xmax - .xmin) / (xmax - xmin)                '拡大率
        End If
    End With
    GetMag0 = ""
    If v >= 1 Then GetMag0 = Format(v, "x#,###")
    
End Function


Private Function GetMag(Optional Target As Range) As String
'
' 拡大率（原図比）
'
    Dim XY As Range
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    
    Set XY = Range("XY")
    
    If Target Is Nothing Then
        x1 = xmin: x2 = xmax: y1 = ymin: y2 = ymax
    Else
        With Target
            Call CellToXY(.Row, .Column, x1, y1)
            Call CellToXY(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1, x2, y2)
        End With
    End If

    If x1 <> x2 Then GetMag = _
            Format((INIT_AMAX - INIT_AMIN) / (x2 - x1), "x#,###")    '拡大率
End Function


Private Function GetXY(Optional Target As Range) As String
'
' 計算範囲算出
'
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    
    If Target Is Nothing Then
        x1 = xmin: x2 = xmax: y1 = ymin: y2 = ymax
    Else
        With Target
            Call CellToXY(.Row, .Column, x1, y1)
            Call CellToXY(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1, x2, y2)
        End With
    End If
    
    GetXY = x1 & " , " & y1 & " : " & x2 & " , " & y2            '計算範囲

End Function


Private Function CellToXY(r As Integer, c As Integer, ByRef x As Double, ByRef y As Double)
'
' セル座標から計算座標を求める
'
' 　出力：x,y
        If CMax = 0 Then Exit Function
        x = xmin + (xmax - xmin) * (c - CMin) / (CMax - CMin)
        y = ymin + (ymax - ymin) * (r - RMin) / (RMax - RMin)
End Function