Option Explicit
Option Base 0
Public Sub 迷路描画マクロ()
Const MAZEXCNT = 12 '迷路横方向マス数
Const MAZEYCNT = 12 '迷路縦方向マス数
'
Const MAZELEFT = 80 '迷路描画開始位置
Const MAZETOPP = 60 '迷路
'
Const MAZEWIDT = 240 '迷路幅
Const MAZEHEIG = 240 '迷路高
'
Const MAZEWCOL = vbBlue '迷路壁線色
Const MAZEWWEI = 1.5 ' 太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, Kp As Integer, Lp As Integer
Dim intGrWd As Integer, intGrHe As Integer, intXp As Integer
Dim intYp As Integer
Dim intMzDt(MAZEXCNT - 1, MAZEYCNT - 1, 2) As Integer
Dim intRn As Integer, intXb As Integer, intYb As Integer
Dim intCn As Integer, intXw As Integer, intYw As Integer
Dim lngCl As Long
'
'
'*アルゴリズムは穴掘り法で。
GoSub 迷路データ生成S1 '
'*外枠
With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _
MAZELEFT, MAZETOPP, MAZEWIDT, MAZEHEIG)
.Fill.Visible = False
.Line.ForeColor.RGB = MAZEWCOL
.Line.Weight = MAZEWWEI
.Line.Visible = True
End With
'*マス
intGrWd = MAZEWIDT \ MAZEXCNT
intGrHe = MAZEHEIG \ MAZEYCNT
For Jp = 0 To MAZEYCNT - 1
For Ip = 0 To MAZEXCNT - 1
intXp = MAZELEFT + intGrWd * Ip
intYp = MAZETOPP + intGrHe * Jp
'
If Ip < MAZEXCNT - 1 And _
(intMzDt(Ip, Jp, 2) And &H1) <> 0 Then
With ActiveDocument.Shapes.AddLine(intXp+intGrWd, _
intYp, intXp + intGrWd, intYp + intGrHe).Line
.ForeColor.RGB = MAZEWCOL '←線色
.Weight = MAZEWWEI '←線の太さ
.DashStyle = msoLineSolid '←線のスタイル
.Visible = msoTrue
End With
End If
If Jp < MAZEYCNT - 1 And _
(intMzDt(Ip, Jp, 2) And &H2) <> 0 Then
With ActiveDocument.Shapes.AddLine(intXp, intYp + _
intGrHe, intXp + intGrWd, intYp + intGrHe).Line
.ForeColor.RGB = MAZEWCOL '←線色
.Weight = MAZEWWEI '←線の太さ
.DashStyle = msoLineSolid '←線のスタイル
.Visible = msoTrue
End With
End If
Next Ip
Next Jp
Exit Sub
'==========================================
迷路データ生成S1: '/サブルーチン
'*テーブルクリア
For Jp = 0 To MAZEYCNT - 1
For Ip = 0 To MAZEXCNT - 1
intMzDt(Ip, Jp, 0) = 0 'ルート番号
intMzDt(Ip, Jp, 1) = 0 '道順
intMzDt(Ip, Jp, 2) = 0 '壁情報 1:右辺 2:下辺
Next Ip
Next Jp
'
Randomize '*乱数列初期化
'
'*迷路の道作成
intXp = 0: intYp = 0
'最初
intRn = 1: GoSub 迷路データ生成S2
'二番目以降
For intRn = 2 To 9999
'起点マス検索
intXp = -1: intYp = -1
For Jp = 0 To MAZEYCNT - 1
For Ip = 0 To MAZEXCNT - 1
If intMzDt(Ip, Jp, 0) = 0 Then
intXp = Ip: intYp = Jp: Exit For
End If
Next Ip
If intXp >= 0 And intYp >= 0 Then Exit For
Next Jp
'見つからなければ終了
If intXp = -1 And intYp = -1 Then Exit For
GoSub 迷路データ生成S2
Next intRn
'
'*迷路の壁作成
For Jp = 0 To MAZEYCNT - 1
For Ip = 0 To MAZEXCNT - 1
If Ip < MAZEXCNT - 1 Then
If intMzDt(Ip, Jp, 0) = intMzDt(Ip + 1, Jp, 0) And _
Abs(intMzDt(Ip, Jp, 1) - intMzDt(Ip + 1, Jp, 1)) = 1 Then
intMzDt(Ip, Jp, 2) = intMzDt(Ip, Jp, 2) Or &H0
Else
intMzDt(Ip, Jp, 2) = intMzDt(Ip, Jp, 2) Or &H1
End If
End If
If Jp < MAZEYCNT - 1 Then
If intMzDt(Ip, Jp, 0) = intMzDt(Ip, Jp + 1, 0) And _
Abs(intMzDt(Ip, Jp, 1) - intMzDt(Ip, Jp + 1, 1)) = 1 Then
intMzDt(Ip, Jp, 2) = intMzDt(Ip, Jp, 2) Or &H0
Else
intMzDt(Ip, Jp, 2) = intMzDt(Ip, Jp, 2) Or &H2
End If
End If
Next Ip
Next Jp
'*ルート毎の道結合
For Jp = 0 To MAZEYCNT - 1
For Ip = 0 To MAZEXCNT - 1
'ルート番号が２以上が対象
If intMzDt(Ip, Jp, 0) > 1 And intMzDt(Ip, Jp, 1) = 1 Then
intCn = 0: Lp = -1
For Kp = 0 To 3 '異なるルート番号の最大道順隣接マス検索
intXp = Ip + Choose(Kp + 1, 0, 1, 0, -1)
intYp = Jp + Choose(Kp + 1, -1, 0, 1, 0)
If intXp >= 0 And intYp >= 0 And _
intXp < MAZEXCNT And intYp < MAZEYCNT Then
If intMzDt(Ip, Jp, 0) <> intMzDt(intXp, intYp, 0) Then
If intMzDt(intXp, intYp, 1) > intCn Then
intCn = intMzDt(intXp, intYp, 1): Lp = Kp
End If
End If
End If
Next Kp
If Lp >= 0 Then '対象マスの壁を削除
Select Case Lp
Case 0:
intMzDt(Ip, Jp - 1, 2) = intMzDt(Ip, Jp - 1, 2) And &HFFFD
Case 1:
intMzDt(Ip, Jp - 0, 2) = intMzDt(Ip, Jp - 0, 2) And &HFFFE
Case 2:
intMzDt(Ip, Jp - 0, 2) = intMzDt(Ip, Jp - 0, 2) And &HFFFD
Case 3:
intMzDt(Ip - 1, Jp, 2) = intMzDt(Ip - 1, Jp, 2) And &HFFFE
End Select
End If
End If
Next Ip
Next Jp
Return
'==========================================
迷路データ生成S2: '/サブルーチン
intCn = 1 '道順
intMzDt(intXp, intYp, 0) = intRn: intMzDt(intXp, intYp, 1) = intCn
Do
intXb = intXp: intYb = intYp:
Jp = Int(4 * Rnd)
For Ip = 0 To 3
intXw = intXp + Choose(((Ip + Jp) Mod 4) + 1, 0, 1, 0, -1)
intYw = intYp + Choose(((Ip + Jp) Mod 4) + 1, -1, 0, 1, 0)
If intXw >= 0 And intYw >= 0 And _
intXw < MAZEXCNT And intYw < MAZEYCNT Then
If intMzDt(intXw, intYw, 0) = 0 Then
intXp = intXw: intYp = intYw: intCn = intCn + 1
intMzDt(intXp, intYp, 0) = intRn
intMzDt(intXp, intYp, 1) = intCn
Exit For
End If
End If
Next Ip
'行き止まりか、ゴールなら終わり
If intXb = intXp And intYb = intYp Then Exit Do
If intXp = MAZEXCNT - 1 And intYp = MAZEYCNT - 1 Then Exit Do
Loop While True
Return
End Sub
Const MAZEXCNT = 24 '迷路横方向マス数
Const MAZEYCNT = 24 '迷路縦方向マス数
《参考》作成時間 およそ116秒
蛇足
「人生こそが、最高・最低の迷路だ」と、どこかの偉い人が言っていたような・・・。
