Excel将棋：駒を成る(№11)
Excelで将棋を作ってみましょう。
人vs人で動かしてゲームとして成立するところまでが当面の目標です。
ただし、将棋では成らない選択も出来ますので、成れるタイミングで成るか成らないかを選択できるようにします。
駒が成れる条件
・敵陣に入った場合
・敵陣内で動いた場合
・敵陣から外に出た場合
・敵陣内で動いた場合
・敵陣から外に出た場合
作成するクラス全体の当初の設計は、№2. Excel将棋：クラスの設計、こちらを参照してください。
・作成するクラスの役割と作成順 ・作成するクラスのメンバー一覧 ・駒の移動の定義 ・Excel将棋の目次
※クラス名、プロシージャー名、変数名に日本語を使用しています。
主な変更追加箇所
将棋進行クラス
盤面表示で、成り駒の赤表示に対応。
シート消去で初期文字色として黒に設定するようにしました。
将棋盤クラス
今回の駒を成らせるための機能を持つクラスになります。
プロシージャーレベル変数「pAry駒」を直接参照している部分が不統一だったので、これを統一するためにプロパティ「Set 駒」を追加しました。
コメントだけ入れていた成り判定を実装しました。
着手では、成り判定からTrue/Falseを受け取り、駒オブジェクトに設定。
create棋譜だけプロシージャーの命名が違っていたので、棋譜作成に変更。
棋譜作成では「成」の記述に対応。
棋譜作成では「成」の記述に対応。
駒クラス
龍馬の移動可能場所の定義データ（cns龍馬移動）に誤りがあったので修正。
プロパティ「表示名称」は盤上表示（成っていれば成り駒の名称）を返していました。
棋譜に使用する本来の駒名を取得するためにプロパティ「通常名称」を追加しました。
棋譜に使用する本来の駒名を取得するためにプロパティ「通常名称」を追加しました。
Excel将棋の動作
現時点の動作です。
変更したクラスのVBA
大まかにですが、変更箇所を太字にしていま。
将棋進行クラス
Option Explicit
'盤面配色定数：自由に設定可
Private Const cnsFont As String = "AR教科書体M"
Private Const cns将棋盤色 As Long = &H75DEFF 'RGB(255, 222, 117)
Private Const cns駒選択色 As Long = &HD9E4FC 'RGB(252, 228, 217)
'API
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'イベント用
Private WithEvents xlApp As Excel.Application
Private p前回選択 As Range
Private p今回選択 As Range
'Excel将棋の書くオブジェクト
Private obj将棋盤 As cls将棋盤
Private obj先手駒台 As cls駒台
Private obj後手駒台 As cls駒台
'シートおよび名前定義の設定
Private pWs As Worksheet
Private p開始位置 As Range
Private p将棋盤 As Range
Private p先手持駒 As Range
Private p後手持駒 As Range
Private p先手時間 As Range
Private p後手時間 As Range
Private p手数 As Range
Private p棋譜 As Range
Private p将棋盤色 As Range
Private p駒選択色 As Range
'先手後手の定数
Private Const c先手 As Boolean = True
Private Const c後手 As Boolean = False
'その他変数
Private dt最終時刻 As Date
Private dt先手時間 As Date
Private dt後手時間 As Date
'選択場所の反対
Private Enum e場所
将棋盤
先手持駒
後手持駒
End Enum
'**********************************************************************
' 公開メソッド：ゲーム開始だけ、他はイベントで処理
'**********************************************************************
Public Sub ゲーム開始()
'シート選択
Dim flgNew As Boolean
On Error Resume Next
Set p開始位置 = ActiveSheet.Range("開始駒位置")
If Err Then
Err.Clear
Set p開始位置 = Application.InputBox( _
prompt:="将棋盤を作成するシートの作成開始左上をクリックしてください。" & vbLf & _
"※シートは全消去されます。", _
Title:="作成シート選択", _
Type:=8)
If Err Then Exit Sub
flgNew = True
Else
flgNew = False
End If
On Error GoTo 0
Set pWs = p開始位置.Worksheet
Application.Goto p開始位置
Application.Cursor = xlWait
Application.ScreenUpdating = False
Set xlApp = Nothing
If flgNew Then
'新規シート
pWs.Cells.Clear
ActiveWindow.DisplayGridlines = False
pWs.Names.Add Name:="開始駒位置", RefersToLocal:=p開始位置
Call シート名前定義
Call シート書式設定
Else
'既存シート
Call シート名前定義
Call シート消去
End If
Set xlApp = p開始位置.Application
Application.ScreenUpdating = True
Call 駒配置 '大橋流でゆっくり並べる
Application.Cursor = xlDefault
dt最終時刻 = Now(): dt先手時間 = 0: dt後手時間 = 0
End Sub
'**********************************************************************
' イベント
'**********************************************************************
Private Sub Class_Initialize()
Set obj将棋盤 = New cls将棋盤
Set obj先手駒台 = New cls駒台
Set obj後手駒台 = New cls駒台
End Sub
Private Sub Class_Terminate()
Set xlApp = Nothing
Set obj将棋盤 = Nothing
Set obj先手駒台 = Nothing
Set obj後手駒台 = Nothing
End Sub
'WithEventsのxlAppのイベント
Private Sub xlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If p将棋盤 Is Nothing Then Exit Sub
If Not Sh Is p将棋盤.Worksheet Then Exit Sub
'いったん盤全体と駒台を既定色に
p将棋盤.Interior.Color = p将棋盤色.Interior.Color
p先手持駒.Interior.Color = p将棋盤色.Interior.Color
p後手持駒.Interior.Color = p将棋盤色.Interior.Color
Call 選択セルを手番に移動
Set p前回選択 = p今回選択
Set p今回選択 = Target.Item(1)
Select Case 選択場所(Target.Item(1))
Case e場所.将棋盤
Call 駒選択将棋盤
Case e場所.先手持駒, e場所.後手持駒
Call 駒選択駒台
End Select
End Sub
'**********************************************************************
' ゲーム開始で駒を並べる
'**********************************************************************
'大橋流でゆっくり駒を並べます。
Private Sub 駒配置()
Dim ary駒配置
ary駒配置 = Array( _
Array(5, 9, "玉", c先手), Array(5, 1, "玉", c後手), _
Array(6, 9, "金", c先手), Array(4, 1, "金", c後手), _
Array(4, 9, "金", c先手), Array(6, 1, "金", c後手), _
Array(7, 9, "銀", c先手), Array(3, 1, "銀", c後手), _
Array(3, 9, "銀", c先手), Array(7, 1, "銀", c後手), _
Array(8, 9, "桂", c先手), Array(2, 1, "桂", c後手), _
Array(2, 9, "桂", c先手), Array(8, 1, "桂", c後手), _
Array(9, 9, "香", c先手), Array(1, 1, "香", c後手), _
Array(1, 9, "香", c先手), Array(9, 1, "香", c後手), _
Array(8, 8, "角", c先手), Array(2, 2, "角", c後手), _
Array(2, 8, "飛", c先手), Array(8, 2, "飛", c後手), _
Array(5, 7, "歩", c先手), Array(5, 3, "歩", c後手), _
Array(6, 7, "歩", c先手), Array(4, 3, "歩", c後手), _
Array(4, 7, "歩", c先手), Array(6, 3, "歩", c後手), _
Array(7, 7, "歩", c先手), Array(3, 3, "歩", c後手), _
Array(3, 7, "歩", c先手), Array(7, 3, "歩", c後手), _
Array(8, 7, "歩", c先手), Array(2, 3, "歩", c後手), _
Array(2, 7, "歩", c先手), Array(8, 3, "歩", c後手), _
Array(9, 7, "歩", c先手), Array(1, 3, "歩", c後手), _
Array(1, 7, "歩", c先手), Array(9, 3, "歩", c後手))
DoEvents
Sleep 300
Dim i As Long, j As Long
With obj将棋盤
For i = LBound(ary駒配置) To UBound(ary駒配置)
.着手 ary駒配置(i)(2), Nothing, 棋譜位置(ary駒配置(i)(0), ary駒配置(i)(1)), ary駒配置(i)(3)
Call 盤面表示(obj将棋盤.現在盤面, obj先手駒台.駒台一覧, obj後手駒台.駒台一覧)
Sleep 100
Next
End With
End Sub
'棋譜の筋・段を配列の行・列に変換
Private Function 棋譜位置(ByVal arg列 As Integer, ByVal arg行 As Integer) As g位置
Set 棋譜位置 = g位置(arg行, 10 - arg列)
End Function
'**********************************************************************
' イベントSheetSelectionChangeから直接呼ばれるプロシージャー
'**********************************************************************
'盤内を選択した時に駒選択と移動可能位置の色設定を行う
'移動可能位置をクリックした場合は着手し駒を移動する
Private Sub 駒選択将棋盤()
If p今回選択 Is Nothing Then: Stop: Exit Sub
'同じ駒を選択したときは解除
If Not p前回選択 Is Nothing Then
If p前回選択.Address = p今回選択.Address Then
Call 選択解除
Exit Sub
End If
End If
'着手して駒を移動
If Not p前回選択 Is Nothing Then
If 駒移動可能(p前回選択, p今回選択) Then
Call 着手(p前回選択, p今回選択)
Call 選択解除
Exit Sub
End If
End If
'最初の選択は手番の駒以外（相手の駒）は選択できない
If p今回選択.Value <> "" Then
If obj将棋盤.駒(セル2位置(p今回選択)).先手 <> obj将棋盤.先手 Then
Call 選択解除
Exit Sub
End If
End If
'駒のない場所の選択は無視
If p今回選択.Value = "" Then
Call 選択解除
Exit Sub
End If
'選択駒と移動可能位置の色変更
p今回選択.Interior.Color = p駒選択色.Interior.Color
Call 駒移動可能位置色変更(obj将棋盤.駒移動可能位置(セル2位置(p今回選択)))
End Sub
'駒台を選択した時に選択した駒の色を変更
Private Sub 駒選択駒台()
Dim tmp駒台 As cls駒台
Set tmp駒台 = IIf(obj将棋盤.先手, obj先手駒台, obj後手駒台)
Dim tmp持駒 As Range
Set tmp持駒 = IIf(obj将棋盤.先手, p先手持駒, p後手持駒)
'いったん持駒を既定色に
tmp持駒.Interior.Color = p将棋盤色.Interior.Color
If p今回選択 Is Nothing Then: Stop: Exit Sub
'同じ駒を選択したときは解除
If Not p前回選択 Is Nothing Then
If p前回選択.Address = p今回選択.Address Then
Call 選択解除
Exit Sub
End If
End If
'駒のない場所の選択は無視
If p今回選択.Value = "" Then
Call 選択解除
Exit Sub
End If
'選択駒の色変更
p今回選択.Interior.Color = p駒選択色.Interior.Color
End Sub
'**********************************************************************
' 着手と場面表示：将棋進行の中核プロシージャー
'**********************************************************************
'駒選択後に移動可能位置を選択したら着手します
Private Sub 着手(ByVal arg元選択 As Range, ByVal arg先選択 As Range)
'画面表示にかかる時間を含めないようにここで処理
If obj将棋盤.先手 Then
dt先手時間 = dt先手時間 + Now() - dt最終時刻
Else
dt後手時間 = dt後手時間 + Now() - dt最終時刻
End If
'着手してシートを更新
Dim tmp駒台 As cls駒台
Set tmp駒台 = IIf(obj将棋盤.先手, obj先手駒台, obj後手駒台)
If arg先選択.Value <> "" Then
'駒台へ
Call tmp駒台.駒追加(obj将棋盤.駒(セル2位置(arg先選択)))
'盤から削除
Call obj将棋盤.着手(arg先選択.Value, セル2位置(arg先選択), g位置(0, 0), obj将棋盤.先手)
End If
If 選択場所(arg元選択) = 将棋盤 Then
'盤上で駒移動
Call obj将棋盤.着手(arg元選択.Value, セル2位置(arg元選択), セル2位置(arg先選択), obj将棋盤.先手)
Else
'盤上へ駒を打つ
Call obj将棋盤.着手(arg元選択.Value, g位置(0, 0), セル2位置(arg先選択), obj将棋盤.先手)
'駒台から削除
Call tmp駒台.駒削除(arg元選択.Value)
End If
Call 盤面表示(obj将棋盤.現在盤面, _
obj先手駒台.駒台一覧, obj後手駒台.駒台一覧, _
obj将棋盤.棋譜, obj将棋盤.棋譜履歴.Count)
Call 選択セルを手番に移動
End Sub
'盤面配列をシートに表示する
Private Sub 盤面表示(ByRef arg盤面() As String, _
ByRef arg先手駒台() As Variant, _
ByRef arg後手駒台() As Variant, _
Optional ByVal arg棋譜 As String, _
Optional ByVal arg手数 As Long)
Application.ScreenUpdating = False
'将棋盤
Dim i As Long, j As Long
For i = 1 To 9
For j = 1 To 9
With p将棋盤(i, j)
If Right(arg盤面(i, j), 1) = "↑" Then
'先手書式
If .Font.Name <> cnsFont Then
.Font.Name = cnsFont
End If
If .Orientation <> xlHorizontal Then
.Orientation = xlHorizontal
End If
ElseIf Right(arg盤面(i, j), 1) = "↓" Then
'後手書式
If .Font.Name <> "@" & cnsFont Then
.Font.Name = "@" & cnsFont
End If
If .Orientation <> xlUpward Then
.Orientation = xlUpward
End If
End If
'表示文字
If .Value <> Trim(Left(arg盤面(i, j), 1)) Then
.Value = Trim(Left(arg盤面(i, j), 1))
End If
'成金
Select Case .Value
Case "龍", "馬", "全", "圭", "杏", "と"
.Font.Color = vbRed
Case Else
If .Font.Color = vbRed Then
.Font.Color = vbBlack
End If
End Select
End With
Next
Next
'先手持駒
p先手持駒.Value = obj先手駒台.駒台一覧
'後手持駒
p後手持駒.Value = 配列180度回転(obj後手駒台.駒台一覧)
'棋譜・手数表示
If arg棋譜 <> "" Then
p棋譜.Value = arg棋譜
p手数.Value = arg手数
p先手時間.Value = dt先手時間
p後手時間.Value = dt後手時間
dt最終時刻 = Now()
End If
Application.ScreenUpdating = True
DoEvents
End Sub
'**********************************************************************
' シートに関する単一機能のSubプロシージャー
'**********************************************************************
'前回選択と今回選択を消去して選択状態を解除
Private Sub 選択解除()
Set p前回選択 = Nothing
Set p今回選択 = Nothing
End Sub
'次のSheetSelectionChangeが効くように先手後手の位置へ選択セルを移動させる
Private Sub 選択セルを手番に移動()
xlApp.EnableEvents = False
xlApp.Goto IIf(obj将棋盤.先手, p先手時間.Offset(, -1), p後手時間.Offset(, -1))
xlApp.EnableEvents = True
End Sub
'駒を選択した時に駒の移動可能位置の色設定を行う
Private Sub 駒移動可能位置色変更(ByVal argCol As Collection)
If argCol Is Nothing Then Exit Sub
Dim tmp位置 As g位置
For Each tmp位置 In argCol
p将棋盤.Resize(1, 1).Offset(tmp位置.行 - 1, tmp位置.列 - 1).Interior.Color = p駒選択色.Interior.Color
Next
End Sub
'**********************************************************************
' 汎用関数：引数はRange、配列、g位置
'**********************************************************************
'駒選択後の次のクリックが移動可能場所かの判定
Private Function 駒移動可能(ByVal arg元選択 As Range, ByVal arg先選択 As Range) As Boolean
駒移動可能 = False
Dim flg移動 As Boolean: flg移動 = False
If 選択場所(arg先選択) = 将棋盤 Then
If 選択場所(arg元選択) = 将棋盤 Then
駒移動可能 = 移動可能範囲(セル2位置(arg元選択), セル2位置(arg先選択))
Else
If arg先選択.Value = "" Then
駒移動可能 = True
End If
End If
End If
End Function
'セル選択位置を配列の位置に変換
Private Function セル2位置(ByVal argRng As Range) As g位置
Dim r As Long, c As Long
r = argRng.Row - p将棋盤.Row + 1
c = argRng.Column - p将棋盤.Column + 1
Set セル2位置 = g位置(r, c)
End Function
'2次元配列を180度回転させる：実引数はRangeを想定
Private Function 配列180度回転(ByRef argAry) As Variant
Dim inAry, outAry
inAry = argAry
ReDim outAry(LBound(inAry, 1) To UBound(inAry, 1), LBound(inAry, 2) To UBound(inAry, 2))
Dim i As Long, j As Long
For i = LBound(inAry, 1) To UBound(inAry, 1)
For j = LBound(inAry, 2) To UBound(inAry, 2)
outAry(UBound(inAry, 1) - i + LBound(inAry, 1), UBound(inAry, 2) - j + LBound(inAry, 2)) = inAry(i, j)
Next
Next
配列180度回転 = outAry
End Function
'移動可能範囲を判定してTrue/Falseで返す
Private Function 移動可能範囲(ByVal arg元位置 As g位置, ByVal arg先位置 As g位置) As Boolean
Dim tmp可能位置 As g位置
For Each tmp可能位置 In obj将棋盤.駒移動可能位置(arg元位置)
If tmp可能位置.行 = arg先位置.行 And _
tmp可能位置.列 = arg先位置.列 Then
移動可能範囲 = True
Exit Function
End If
Next
移動可能範囲 = False
End Function
'選択場所をEnumで返す
Private Function 選択場所(ByVal argRange As Range) As e場所
選択場所 = -1
Select Case False
Case Intersect(p将棋盤, argRange) Is Nothing
選択場所 = e場所.将棋盤
Case Intersect(p先手持駒.Resize(, 1), argRange) Is Nothing
If obj将棋盤.先手 Then
選択場所 = e場所.先手持駒
End If
Case Intersect(p後手持駒.Offset(, 1).Resize(, 1), argRange) Is Nothing
If Not obj将棋盤.先手 Then
選択場所 = e場所.後手持駒
End If
End Select
End Function
'玉の詰み判定し、詰んでいれば終局
Private Function 終局判定() As Boolean
'※※※これは難しいので後回し※※※
'cls将棋盤の終局判定を使用する
End Function
'**********************************************************************
' シート設定：名前定義と書式設定
'**********************************************************************
Private Sub シート消去()
p将棋盤.ClearContents
p先手持駒.ClearContents
p後手持駒.ClearContents
p先手時間.ClearContents
p後手時間.ClearContents
p手数.ClearContents
p棋譜.ClearContents
p将棋盤.Interior.Color = cns将棋盤色
p将棋盤.Font.Color = vbBlack
p先手持駒.Interior.Color = cns将棋盤色
p後手持駒.Interior.Color = cns将棋盤色
End Sub
Private Sub シート名前定義()
With pWs
.Names.Add Name:="将棋盤", RefersToLocal:=p開始位置.Offset(4, 5).Resize(9, 9)
.Names.Add Name:="先手持駒", RefersToLocal:=p開始位置.Offset(6, 16).Resize(7, 2)
.Names.Add Name:="先手時間", RefersToLocal:=p開始位置.Offset(15, 12).Resize(1, 2)
.Names.Add Name:="後手持駒", RefersToLocal:=p開始位置.Offset(4, 1).Resize(7, 2)
.Names.Add Name:="後手時間", RefersToLocal:=p開始位置.Offset(1, 6).Resize(1, 2)
.Names.Add Name:="手数", RefersToLocal:=p開始位置.Offset(15, 5)
.Names.Add Name:="棋譜", RefersToLocal:=p開始位置.Offset(15, 6).Resize(1, 3)
.Names.Add Name:="将棋盤色", RefersToLocal:=p開始位置.Offset(0, 18)
.Names.Add Name:="駒選択色", RefersToLocal:=p開始位置.Offset(1, 18)
Set p将棋盤 = .Range("将棋盤")
Set p先手持駒 = .Range("先手持駒")
Set p先手時間 = .Range("先手時間")
Set p後手持駒 = .Range("後手持駒")
Set p後手時間 = .Range("後手時間")
Set p手数 = .Range("手数")
Set p棋譜 = .Range("棋譜")
Set p将棋盤色 = .Range("将棋盤色")
Set p駒選択色 = .Range("駒選択色")
End With
End Sub
Private Sub シート書式設定()
'列幅行高設定()
With p開始位置.EntireColumn
.Offset(, 0).ColumnWidth = 2.4
.Offset(, 1).ColumnWidth = 2.4
.Offset(, 2).ColumnWidth = 4
.Offset(, 3).ColumnWidth = 0.47
.Offset(, 4).ColumnWidth = 1.6
.Offset(, 5).Resize(, 9).ColumnWidth = 4
.Offset(, 14).ColumnWidth = 1.6
.Offset(, 15).ColumnWidth = 0.47
.Offset(, 16).ColumnWidth = 4
.Offset(, 17).ColumnWidth = 2.4
.Offset(, 18).ColumnWidth = 2.4
End With
With p開始位置.EntireRow
.Offset(0).Resize(17).RowHeight = 18
.Offset(2).RowHeight = 4.8
.Offset(3).RowHeight = 13.8
.Offset(4).Resize(9).RowHeight = 28.2
.Offset(13).RowHeight = 13.8
.Offset(14).RowHeight = 4.8
End With
'セル結合設定()
With pWs
.Range("後手時間").Merge
.Range("先手時間").Merge
.Range("棋譜").Merge
End With
'セル書式設定()
With p将棋盤色
.Interior.Color = cns将棋盤色
.BorderAround LineStyle:=xlContinuous
End With
With p駒選択色
.Interior.Color = cns駒選択色
.BorderAround LineStyle:=xlContinuous
End With
With p開始位置
.Resize(17, 19).BorderAround LineStyle:=xlContinuous
End With
With p将棋盤
.Offset(-1, -1).Resize(11, 11).BorderAround LineStyle:=xlContinuous, Weight:=xlThick
.Offset(-1, -1).Resize(11, 11).Interior.Color = p将棋盤色.Interior.Color
.Borders.LineStyle = xlContinuous
.Font.Name = cnsFont
.Font.Size = 20
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Resize(3).Font.Name = "@" & cnsFont '後手陣のみ
.Resize(3).Orientation = xlUpward '後手陣のみ
.Offset(-1).Resize(1).Font.Name = "ＭＳ Ｐゴシック"
.Offset(-1).Resize(1).Font.Size = 8
.Offset(-1).Resize(1).HorizontalAlignment = xlCenter
.Offset(-1).Resize(1).VerticalAlignment = xlCenter
.Offset(, 9).Resize(, 1).Font.Name = "ＭＳ Ｐゴシック"
.Offset(, 9).Resize(, 1).Font.Size = 8
.Offset(, 9).Resize(, 1).HorizontalAlignment = xlCenter
.Offset(, 9).Resize(, 1).VerticalAlignment = xlCenter
End With
With p先手持駒
.BorderAround LineStyle:=xlContinuous
.Interior.Color = p将棋盤色.Interior.Color
.Offset(, 0).Resize(, 1).Font.Name = cnsFont
.Offset(, 0).Resize(, 1).Font.Size = 20
.Offset(, 0).Resize(, 1).Font.Bold = True
.Offset(, 0).Resize(, 1).HorizontalAlignment = xlCenter
.Offset(, 1).Resize(, 1).Font.Name = "ＭＳ Ｐゴシック"
.Offset(, 1).Resize(, 1).Font.Size = 11
.Offset(, 1).Resize(, 1).Font.Bold = True
.Offset(, 1).Resize(, 1).HorizontalAlignment = xlLeft
End With
With p後手持駒
.BorderAround LineStyle:=xlContinuous
.Interior.Color = p将棋盤色.Interior.Color
.Offset(, 1).Resize(, 1).Font.Name = "@" & cnsFont
.Offset(, 1).Resize(, 1).Orientation = xlUpward
.Offset(, 1).Resize(, 1).Font.Size = 20
.Offset(, 1).Resize(, 1).Font.Bold = True
.Offset(, 1).Resize(, 1).HorizontalAlignment = xlCenter
.Offset(, 0).Resize(, 1).Font.Name = "ＭＳ Ｐゴシック"
.Offset(, 0).Resize(, 1).Font.Size = 11
.Offset(, 0).Resize(, 1).Font.Bold = True
.Offset(, 0).Resize(, 1).HorizontalAlignment = xlRight
End With
With p先手時間
.Offset(, -1).Resize(, 3).BorderAround LineStyle:=xlContinuous
.Offset(, -1).Resize(, 3).Interior.Color = vbBlack
.Offset(, -1).Resize(, 3).Font.Name = "ＭＳ Ｐゴシック"
.Offset(, -1).Resize(, 3).Font.Size = 11
.Offset(, -1).Resize(, 3).Font.Bold = True
.Offset(, -1).Resize(, 3).Font.Color = vbWhite
.HorizontalAlignment = xlCenter
.NumberFormatLocal = "h:mm:ss"
End With
With p後手時間
.Offset(, -1).Resize(, 3).BorderAround LineStyle:=xlContinuous
.Offset(, -1).Resize(, 3).Interior.Color = vbWhite
.Offset(, -1).Resize(, 3).Font.Name = "ＭＳ Ｐゴシック"
.Offset(, -1).Resize(, 3).Font.Size = 11
.Offset(, -1).Resize(, 3).Font.Bold = True
.HorizontalAlignment = xlCenter
.NumberFormatLocal = "h:mm:ss"
End With
With p手数
.Resize(, 4).Borders.LineStyle = xlContinuous
.Resize(, 4).Interior.Color = p駒選択色.Interior.Color
.Resize(, 4).Font.Name = "ＭＳ Ｐゴシック"
.Resize(, 4).Font.Size = 11
.Resize(, 4).Font.Bold = True
End With
'文字設定()
p将棋盤.Offset(-1).Resize(1).Value = Array(9, 8, 7, 6, 5, 4, 3, 2, 1)
p将棋盤.Offset(, 9).Resize(, 1).Value = WorksheetFunction.Transpose(Array("一", "二", "三", "四", "五", "六", "七", "八", "九"))
p先手時間.Offset(, -1).Resize(, 1).Value = "先手"
p後手時間.Offset(, -1).Resize(, 1).Value = "後手"
p将棋盤色.Offset(, -2).Value = "将棋盤色"
p駒選択色.Offset(, -2).Value = "駒選択色"
End Sub
将棋盤クラス
Option Explicit
Private pAry駒(1 To 9, 1 To 9) As cls駒
Private p先手 As Boolean
Private pCol盤面 As Collection
Private pCol棋譜 As Collection
Private Sub Class_Initialize()
Me.先手 = True
Set pCol盤面 = New Collection
Set pCol棋譜 = New Collection
End Sub
Private Sub Class_Terminate()
Set pCol盤面 = Nothing
Set pCol棋譜 = Nothing
End Sub
'**********************************************************************
' 公開プロパティ
'**********************************************************************
Public Property Get 現在盤面() As String()
Dim ary盤 As Variant
If pCol盤面.Count = 0 Then
ary盤 = pAry駒
Else
ary盤 = pCol盤面(pCol盤面.Count)
End If
Dim out盤面() As String
ReDim out盤面(LBound(ary盤, 1) To UBound(ary盤, 1), _
LBound(ary盤, 2) To UBound(ary盤, 2))
Dim i As Long, j As Long
For i = LBound(ary盤, 1) To UBound(ary盤, 1)
For j = LBound(ary盤, 2) To UBound(ary盤, 2)
If ary盤(i, j) Is Nothing Then
out盤面(i, j) = " "
Else
out盤面(i, j) = ary盤(i, j).表示名称 & _
IIf(ary盤(i, j).先手, "↑", "↓")
End If
Next
Next
現在盤面 = out盤面
End Property
Public Property Get 盤面履歴()
Set 盤面履歴 = pCol盤面
End Property
Public Property Get 棋譜() As String
棋譜 = pCol棋譜(pCol棋譜.Count)
End Property
Public Property Get 棋譜履歴() As Collection
Set 棋譜履歴 = pCol棋譜
End Property
Public Property Get 手数() As String
手数 = pCol棋譜.Count
End Property
Public Property Let 先手(ByVal Value As Boolean)
p先手 = Value
End Property
Public Property Get 先手() As Boolean
先手 = p先手
End Property
Public Property Set 駒(ByVal arg位置 As g位置, ByVal arg駒 As cls駒)
Set pAry駒(arg位置.行, arg位置.列) = arg駒
End Property
Public Property Get 駒(ByVal arg位置 As g位置) As cls駒
Set 駒 = pAry駒(arg位置.行, arg位置.列)
End Property
'**********************************************************************
' 公開メソッド
'**********************************************************************
'駒が移動できる位置をg位置（行、列）のCollectionで返す
Public Function 駒移動可能位置(ByVal arg位置 As g位置) As Collection
If Me.駒(arg位置) Is Nothing Then Exit Function
Set 駒移動可能位置 = Me.駒(arg位置).駒移動可能位置(pAry駒)
End Function
Public Sub 着手(ByVal arg駒名 As String, _
ByVal arg元位置 As g位置, _
ByVal arg先位置 As g位置, _
ByVal arg先手 As Boolean)
'元位置：-1,-1は初期配置
'位置：0,0は駒台の出し入れ
Dim obj駒 As cls駒
Dim is成り As Boolean
Select Case True
Case arg元位置 Is Nothing '初期配置
Set obj駒 = New cls駒
Set Me.駒(arg先位置) = obj駒.駒作成(arg駒名, arg先手, arg先位置)
'棋譜は不要
Exit Sub
Case arg先位置.行 = 0 '駒台へ
Set Me.駒(arg元位置) = Nothing
'棋譜は不要
Exit Sub
Case arg元位置.行 = 0 '駒台から
Set obj駒 = New cls駒
Set Me.駒(arg先位置) = obj駒.駒作成(arg駒名, arg先手, arg先位置)
Case Else '駒移動
Set Me.駒(arg先位置) = Me.駒(arg元位置)
Set Me.駒(arg先位置).駒位置 = arg先位置
'今回成ったかの情報
Me.駒(arg先位置).成り = 成り判定(arg元位置, arg先位置, is成り)
End Select
'棋譜履歴
If arg元位置.行 = 0 Then
pCol棋譜.Add 棋譜作成(Nothing, Me.駒(arg先位置), False)
Else
pCol棋譜.Add 棋譜作成(Me.駒(arg元位置), Me.駒(arg先位置), is成り)
'棋譜作成で元位置が必要なので、棋譜作成後のここで消す
Set Me.駒(arg元位置) = Nothing
End If
'盤面履歴
pCol盤面.Add pAry駒
Call 手番交代
End Sub
Public Function 終局判定() As Boolean
'※※※これは難しいので後回し※※※
'持駒を含めた全ての駒を使って受けがないかの判定
End Function
'**********************************************************************
' 非公開メソッド
'**********************************************************************
Private Sub 手番交代()
Me.先手 = Not Me.先手
End Sub
'棋譜の表記方法：https://www.shogi.or.jp/faq/kihuhyouki.html
'棋譜ほMi2形式で作成（▲５ニ銀右上成）
Private Function 棋譜作成(ByVal arg駒元 As cls駒, _
ByVal arg駒先 As cls駒, _
ByRef arg成り As Boolean) As String
Dim ary(1 To 7) As String
ary(1) = IIf(Me.先手, "▲", "△")
ary(2) = StrConv(10 - arg駒先.駒位置.列, vbWide)
ary(3) = WorksheetFunction.Text(arg駒先.駒位置.行, "[DBNum1]0")
ary(4) = arg駒先.通常名称
ary(5) = get駒の相対位置(arg駒先)
ary(6) = get駒の動作(arg駒先)
If arg駒元 Is Nothing Then
ary(7) = "打"
Else
ary(7) = IIf(arg成り, "成", "")
End If
棋譜作成 = Join(ary, "")
End Function
Private Function 成り判定(ByRef arg元位置 As g位置, _
ByVal arg先位置 As g位置, _
ByRef arg成り As Boolean) As Boolean
arg成り = False
成り判定 = Me.駒(arg元位置).成り
If Me.駒(arg元位置).成駒名称 = " " Then Exit Function
If 成り判定 Then Exit Function
'敵陣に入った場合、敵陣内で動いた場合、敵陣から外に出た場合
Dim can成り As Boolean
If Me.先手 Then
If arg元位置.行 <= 3 Or arg先位置.行 <= 3 Then
can成り = True
End If
Else
If arg元位置.行 >= 7 Or arg先位置.行 >= 7 Then
can成り = True
End If
End If
If Not can成り Then Exit Function
'成るか成らないかの確認
If MsgBox("成りますか?", vbYesNo, "成り確認") = vbYes Then
arg成り = True
成り判定 = True
End If
End Function
Private Function get駒の相対位置(ByVal arg駒先 As cls駒) As String
'※※※これは難しいので後回し※※※
'右：指す側から見て右側の駒を動かした場合
'左：指す側から見て左側の駒を動かした場合
'直：指す側から見て上に駒を動かした場合
'打：持駒から打った場合
End Function
Private Function get駒の動作(ByVal arg駒先 As cls駒) As String
'※※※これは難しいので後回し※※※
'上：1段以上、上に動く
'寄：1マス以上、横に動く
'引：1段以上、下に動く
End Function
駒クラス
Option Explicit
Private p正式名称 As String
Private p表示名称 As String
Private p成駒名称 As String
Private p表示順 As Integer
Private p先手 As Boolean
Private p成り As Boolean
Private p駒位置 As g位置
Private p駒移動() As cls移動
Private p成駒移動() As cls移動
'**********************************************************************
' 駒の名称や動きの定義
'**********************************************************************
'正式名称,表示名称,成駒名称,表示順
Private Const cns王将定義 As String = "王将,玉, ,0"
Private Const cns飛車定義 As String = "飛車,飛,龍,1"
Private Const cns角行定義 As String = "角行,角,馬,2"
Private Const cns金将定義 As String = "金将,金, ,3"
Private Const cns銀将定義 As String = "銀将,銀,全,4"
Private Const cns桂馬定義 As String = "桂馬,桂,圭,5"
Private Const cns香車定義 As String = "香車,香,杏,6"
Private Const cns歩兵定義 As String = "歩兵,歩,と,7"
'行,列,回数
Private Const cns王将移動 As String = "-1,-1, 1;" & _
"-1, 0, 1;" & _
"-1, 1, 1;" & _
" 0,-1, 1;" & _
" 0, 1, 1;" & _
" 1,-1, 1;" & _
" 1, 0, 1;" & _
" 1, 1, 1;"
Private Const cns飛車移動 As String = "-1, 0, 8;" & _
" 1, 0, 8;" & _
" 0,-1, 8;" & _
" 0, 1, 8;"
Private Const cns龍王移動 As String = "-1, 0, 8;" & _
" 1, 0, 8;" & _
" 0,-1, 8;" & _
" 0, 1, 8;" & _
"-1,-1, 1;" & _
"-1, 1, 1;" & _
" 1,-1, 1;" & _
" 1, 1, 1;"
Private Const cns角行移動 As String = "-1,-1, 8;" & _
"-1, 1, 8;" & _
" 1,-1, 8;" & _
" 1, 1, 8;"
Private Const cns龍馬移動 As String = "-1,-1, 8;" & _
"-1, 1, 8;" & _
" 1,-1, 8;" & _
" 1, 1, 8;" & _
"-1, 0, 1;" & _
" 0,-1, 1;" & _
" 0, 1, 1;" & _
" 1, 0, 1;"
Private Const cns金将移動 As String = "-1,-1, 1;" & _
"-1, 0, 1;" & _
"-1, 1, 1;" & _
" 0,-1, 1;" & _
" 0, 1, 1;" & _
" 1, 0, 1;"
Private Const cns銀将移動 As String = "-1,-1, 1;" & _
"-1, 0, 1;" & _
"-1, 1, 1;" & _
" 1,-1, 1;" & _
" 1, 1, 1;"
Private Const cns桂馬移動 As String = "-2,-1, 1;" & _
"-2, 1, 1;"
Private Const cns香車移動 As String = "-1, 0, 8;"
Private Const cns歩兵移動 As String = "-1, 0, 1;"
Private Sub Class_Initialize()
'引数省略した場合でも()を付ける必要があります。
'()を付けないと既定のメンバーが呼び出されない
Set p駒位置 = g位置()
End Sub
'**********************************************************************
' 公開プロパティ
'**********************************************************************
Public Property Let 正式名称(ByVal Value As String)
p正式名称 = Value
End Property
Public Property Get 正式名称() As String
正式名称 = p正式名称
End Property
Public Property Let 表示名称(ByVal Value As String)
p表示名称 = Value
End Property
Public Property Get 表示名称() As String
表示名称 = IIf(Me.成り, p成駒名称, p表示名称)
End Property
Public Property Get 通常名称() As String
通常名称 = p表示名称
End Property
Public Property Let 成駒名称(ByVal Value As String)
p成駒名称 = Value
End Property
Public Property Get 成駒名称() As String
成駒名称 = p成駒名称
End Property
Public Property Let 表示順(ByVal Value As String)
p表示順 = Value
End Property
Public Property Get 表示順() As String
表示順 = p表示順
End Property
Public Property Let 駒移動(ByRef arg移動() As cls移動)
p駒移動 = arg移動
End Property
Public Property Get 駒移動() As cls移動()
駒移動 = p駒移動
End Property
Public Property Let 成駒移動(ByRef arg移動() As cls移動)
p成駒移動 = arg移動
End Property
Public Property Get 成駒移動() As cls移動()
成駒移動 = p成駒移動
End Property
Public Property Let 先手(ByVal Value As Boolean)
p先手 = Value
End Property
Public Property Get 先手() As Boolean
先手 = p先手
End Property
Public Property Let 成り(ByVal Value As Boolean)
p成り = Value
End Property
Public Property Get 成り() As Boolean
成り = p成り
End Property
Public Property Set 駒位置(ByVal arg駒位置 As g位置)
Set p駒位置 = arg駒位置
End Property
Public Property Get 駒位置() As g位置
Set 駒位置 = p駒位置
End Property
'**********************************************************************
' 公開メソッド
'**********************************************************************
'駒の正式名称を受け取って、その駒特有の情報を設定する
Public Function 駒作成(ByVal arg名称 As String, _
ByVal arg先手 As Boolean, _
Optional ByVal arg位置 As g位置 = Nothing _
) As cls駒
Dim tmp定義 As String
Dim tmp移動 As String, tmp成移動 As String
Select Case arg名称
Case "王将", "玉将", "王", "玉"
tmp定義 = cns王将定義
tmp移動 = cns王将移動
tmp成移動 = "" '成れない
Case "飛車", "飛"
tmp定義 = cns飛車定義
tmp移動 = cns飛車移動
tmp成移動 = cns龍王移動
Case "角行", "角"
tmp定義 = cns角行定義
tmp移動 = cns角行移動
tmp成移動 = cns龍馬移動
Case "金将", "金"
tmp定義 = cns金将定義
tmp移動 = cns金将移動
tmp成移動 = "" '成れない
Case "銀将", "銀"
tmp定義 = cns銀将定義
tmp移動 = cns銀将移動
tmp成移動 = cns金将移動
Case "桂馬", "桂"
tmp定義 = cns桂馬定義
tmp移動 = cns桂馬移動
tmp成移動 = cns金将移動
Case "香車", "香"
tmp定義 = cns香車定義
tmp移動 = cns香車移動
tmp成移動 = cns金将移動
Case "歩兵", "歩"
tmp定義 = cns歩兵定義
tmp移動 = cns歩兵移動
tmp成移動 = cns金将移動
Case Else
Err.Raise 9999 '形式的に記述
End Select
Dim sSplit() As String
sSplit = Split(tmp定義, ",")
Me.正式名称 = sSplit(0)
Me.表示名称 = sSplit(1)
Me.成駒名称 = sSplit(2)
Me.表示順 = sSplit(3)
Me.駒移動 = 駒移動設定(tmp移動)
Me.成駒移動 = 駒移動設定(tmp成移動)
Me.先手 = arg先手
Set Me.駒位置 = arg位置
Set 駒作成 = Me
End Function
'駒が移動できる位置をg位置（行、列）のCollectionで返す
Public Function 駒移動可能位置(ByRef ary盤面() As cls駒) As Collection
Dim col位置 As New Collection
Dim tmp移動 As Variant 'For Eachで使用する都合でVariant
Dim tmp位置 As g位置
Dim i As Long
For Each tmp移動 In IIf(Me.成り, Me.成駒移動, Me.駒移動)
For i = 1 To tmp移動.回数
Set tmp位置 = g位置() '()は省略できない
'先手後手で進む方向を反転させる
tmp位置.行 = Me.駒位置.行 + (tmp移動.行 * i * IIf(Me.先手, 1, -1))
tmp位置.列 = Me.駒位置.列 + (tmp移動.列 * i * IIf(Me.先手, 1, -1))
'盤外に出たら内側のForのみ抜ける
If tmp位置.行 < LBound(ary盤面, 1) Or _
tmp位置.行 > UBound(ary盤面, 1) Or _
tmp位置.列 < LBound(ary盤面, 2) Or _
tmp位置.列 > UBound(ary盤面, 2) Then
Exit For
End If
If ary盤面(tmp位置.行, tmp位置.列) Is Nothing Then
'駒が無いので駒を置ける
col位置.Add tmp位置
Else
'相手の駒なら取れる、自分の駒ならそれ以上進めない
If ary盤面(tmp位置.行, tmp位置.列).先手 <> Me.先手 Then
col位置.Add tmp位置
End If
Exit For
End If
Next
Next
Set 駒移動可能位置 = col位置
End Function
'**********************************************************************
' 非公開メソッド
'**********************************************************************
'駒の動きを定義したConstより配列を作成する
Private Function 駒移動設定(ByVal arg動き As String) As cls移動()
Dim ary移動() As cls移動
Dim tmp移動 As cls移動
Dim sSplit1() As String, sSplit2() As String
Dim i As Long, j As Long
'行,列,回数;行,列,回数;・・・; 最後は;で終わる前提
sSplit1 = Split(arg動き, ";")
If UBound(sSplit1) < 0 Then Exit Function '成らない駒
ReDim ary移動(LBound(sSplit1) To UBound(sSplit1) - 1)
For i = LBound(sSplit1) To UBound(sSplit1) - 1
sSplit2 = Split(sSplit1(i), ",")
Set tmp移動 = New cls移動
tmp移動.行 = sSplit2(LBound(sSplit2) + 0)
tmp移動.列 = sSplit2(LBound(sSplit2) + 1)
tmp移動.回数 = sSplit2(LBound(sSplit2) + 2)
Set ary移動(i) = tmp移動
Next
駒移動設定 = ary移動
End Function
ここまでのVBAコードを組み込んだExcelファイルは以下からダウンロード出来ます。
Excel将棋の目次
№1. Excel将棋：マクロVBAの学習用
・Excel将棋の要件定義 ・Excel将棋のシート作成 ・Excel将棋の目次
№2. Excel将棋：クラスの設計・作成するクラスの役割と作成順 ・作成するクラスのメンバー一覧 ・駒の移動の定義 ・Excel将棋の目次
№3. Excel将棋：駒クラスの作成・位置クラス ・移動クラス ・駒クラス ・駒クラスVBAの解説 ・使用しているVBAの参考ページ ・Excel将棋の目次
№4. Excel将棋：駒クラスの単体テスト・駒クラスのテスト内容 ・駒クラスのテストVBAコード ・駒クラスのテストVBAの結果 ・Excel将棋の目次
№5. Excel将棋：駒台クラスの作成&単体テスト・駒クラス ・駒台クラスVBAの解説 ・駒台クラスのテストVBAコード ・駒クラスのテストVBAの結果 ・Excel将棋の目次
№6. Excel将棋：位置クラスをデフォルトインスタンスに変更・デフォルトインスタンスに変更する理由と方法 ・位置クラスのインポート用ソース ・cls位置とg位置の使い方の違い ・位置クラス変更に伴う駒クラスの変更 ・Excel将棋の目次
№7. Excel将棋：将棋盤クラスの作成&単体テスト・将棋盤クラス ・将棋盤クラスVBAの解説 ・将棋盤クラスのテストVBAコード ・将棋盤クラスのテストVBAの結果 ・Excel将棋の目次
№8. Excel将棋：将棋進行クラスの作成・将棋進行クラス ・将棋進行クラスVBAの解説 ・将棋進行クラスの起動方法 ・将棋盤クラスのテストVBAの結果 ・Excel将棋の目次
№9. Excel将棋：駒を動かす・駒クラスにプロパティ追加 ・将棋進行クラスの変更点 ・将棋進行クラスのVBA ・Excel将棋の実行動作 ・Excel将棋の目次
№10. Excel将棋：相手の駒を取る、持ち駒を打つ・主な変更追加箇所 ・全体の構成 ・Excel将棋の動作 ・Excel将棋の全VBAコード ・Excel将棋の目次
№11. Excel将棋：駒を成る・主な変更追加箇所 ・Excel将棋の動作 ・変更したクラスのVBA ・Excel将棋の目次
№12. Excel将棋：棋譜をユーザーフォームに表示する・棋譜について ・主な変更内容 ・ユーザーフォームの作成 ・Excel将棋の動作 ・変更したクラスのVBA ・Excel将棋の目次
№13. Excel将棋：棋譜選択でその時点の盤面に戻す・Excel将棋の動作 ・全体構成図 ・全プロシージャー・プロパティの一覧 ・クリックで着手した時の主なプロシージャーの流れ ・Excel将棋のダウンロード ・Excel将棋の目次
№14. Excel将棋：棋譜ファイルの出力と読込自動再生・Excel将棋の動作 ・VBAの修正箇所について ・Excel将棋のダウンロード ・棋譜KIFファイルのサンプル ・Excel将棋の目次
№15. Excel将棋：反則（禁じ手）判定・反則（禁じ手） ・Excel将棋の動作 ・各クラスの共通で持つプロパティを整理 ・VBAの修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№16. Excel将棋：終局（詰み）判定と打ち歩詰め・反則（禁じ手） ・Excel将棋の動作 ・VBAの追加・修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№17. Excel将棋：千日手と連続王手の千日手・反則（禁じ手） ・Excel将棋の動作 ・VBAの修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№18 Excel将棋：ひとまず完成、これまでとこれから・Excel将棋のこれから ・Excel将棋の目次 ・Excel将棋のダウンロード ・当初のクラス設計 ・作成するクラスのメンバー一覧 ・全体構成図 ・全プロシージャー・プロパティの一覧 ・全VBAコード
№19 Excel将棋：棋譜ファイルから対局一覧作成・対局一覧のシート ・Excel将棋の動作 ・全体構成図 ・Excel将棋のダウンロード ・新規追加したVBAコード ・Excel将棋の目次
新着記事NEW ・・・新着記事一覧を見る
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- Excel将棋：駒を成る(№11)
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。