VBAサンプル集
Excel将棋:棋譜をユーザーフォームに表示する(№12)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2020-08-31

Excel将棋:棋譜をユーザーフォームに表示する(№12)


VBA マクロ Excel将棋

Excelで将棋を作ってみましょう。
人vs人で動かしてゲームとして成立するところまでが当面の目標です。


今回は、ユーザーフォームを作成し、初手からの棋譜を表示できるようにします。
シート操作ができるように、ユーザーフォームはモードレスで表示します。
棋譜の形式は、KI2形式を予定していましたが、VBAでの作り易さ・棋譜の再現のしやすさ差からKIF形式に変更しました。

※クラス名、プロシージャー名、変数名に日本語を使用しています。

棋譜について

KI2形式

▲2六歩
△3四歩
▲7六歩
△4四歩

KIF形式

手数 筋段駒[成/打](移動元の筋段) (1手の消費時間/累計消費時間)

1 2六歩(27) ( 0:01/00:00:01)
2 8四歩(83) ( 0:01/00:00:01)
3 2五歩(26) ( 0:02/00:00:03)
4 8五歩(84) ( 0:01/00:00:02)

主な変更内容

・標準モジューから起動される将棋進行クラスのゲーム開始では駒を並べないようにする。
・ユーザーフォーム「frm棋譜」を作成し、「対局開始」で駒を並べる。
・駒落ち(手合い割)に対応する。
・大橋流でゆっくり並べるかを選択できるようにする。
・棋譜クラスを作成し、棋譜(消費時間も含む)の管理をここに集約する。
・初手からの棋譜を随時ユーザーフォームのリストボックスに表示する。
・ユーザーフォームを閉じたらゲームを終了させる。

ユーザーフォームの作成

VBA マクロ Excel将棋

オブジェクト名

txt先手
txt後手
cmb手合い割
chk大橋流
btn対局開始
btn棋譜読込 ・・・ 機能は後で実装します
btn棋譜出力 ・・・ 機能は後で実装します
lst棋譜

フォームモジュール

モジュール名:frm棋譜

Option Explicit

Public obj親 As cls将棋進行

Private Sub btn対局開始_Click()
  Me.lst棋譜.Clear
  Call Me.obj親.ゲーム開始(Me.cmb手合い割.Value, Me.chk大橋流.Value)
  Call 先手後手表示
End Sub

Private Sub UserForm_Initialize()
  With Me.cmb手合い割
    .Clear
    .AddItem "平手"
    .AddItem "香落ち"
    .AddItem "角落ち"
    .AddItem "飛車落ち"
    .AddItem "飛車香落ち"
    .AddItem "二枚落ち"
    .AddItem "四枚落ち"
    .AddItem "六枚落ち"
    .AddItem "八枚落ち"
    .AddItem "十枚落ち"
    .ListIndex = 0
  End With
  Me.chk大橋流.Value = False
End Sub

Public Sub 棋譜表示(ByVal arg棋譜 As Collection)
  Dim vItem As Variant
  Me.lst棋譜.Clear
  For Each vItem In arg棋譜
    Me.lst棋譜.AddItem vItem
  Next
  Me.lst棋譜.ListIndex = Me.lst棋譜.ListCount - 1
  Call 先手後手表示
End Sub

Public Sub 棋譜追加(ByVal arg棋譜 As String)
  Me.lst棋譜.AddItem arg棋譜
  Me.lst棋譜.ListIndex = Me.lst棋譜.ListCount - 1
  Call 先手後手表示
End Sub

Private Sub 先手後手表示()
  Me.Caption = IIf(Me.lst棋譜.ListCount Mod 2 = 0, "先手番", "後手番")
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If MsgBox("Excel将棋を終了しますか?", vbYesNo, "終局確認") = vbNo Then
    Cancel = True
    Exit Sub
  End If
End Sub

Private Sub UserForm_Terminate()
  Call obj親.ゲーム終了
End Sub

Excel将棋の動作

現時点の動作です。

VBA マクロ 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 Enum e場所
  将棋盤
  先手持駒
  後手持駒
End Enum

'**********************************************************************
' 公開メソッド:ゲーム開始・終了、他はイベントで処理
'**********************************************************************

Public Sub ゲーム開始(Optional ByVal arg手合い As String, _
           Optional ByVal arg大橋流 As Boolean)

   '標準モジュールから呼ばれた場合、フォームが表示されていたらは処理しない
  If arg手合い = "" Then
    If frm棋譜.Visible Then Exit Sub
  End If

  
  'シート選択
  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
  
  Call Class_Initialize
  Set xlApp = p開始位置.Application
  Application.ScreenUpdating = True
  Call 駒配置(arg手合い, arg大橋流)
  Application.Cursor = xlDefault
  
  With frm棋譜
    If .Visible = False Then .Show vbModeless
    Set .obj親 = Me
  End With

  Application.Goto p先手時間.Offset(, -1)
End Sub

Public Sub ゲーム終了()
  End
End Sub


'**********************************************************************
' イベント
'**********************************************************************

Private Sub Class_Initialize()
  Set obj将棋盤 = New cls将棋盤
  Set obj将棋盤.obj親 = Me
  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 駒選択駒台
    Case Else
      Call 選択解除
  End Select
End Sub

'**********************************************************************
' ゲーム開始で駒を並べる
'**********************************************************************

'大橋流でゆっくり駒を並べます。
Private Sub 駒配置(ByVal arg手合い As String, ByVal arg大橋流 As Boolean)
  If arg手合い = "" Then Exit 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後手))
  Select Case arg手合い
    Case "香落ち"
      ary駒配置(14)(2) = ""
    Case "角落ち"
      ary駒配置(18)(2) = ""
    Case "飛車落ち"
      ary駒配置(20)(2) = ""
    Case "飛車香落ち"
      ary駒配置(14)(2) = ""
      ary駒配置(20)(2) = ""
    Case "二枚落ち"
      ary駒配置(18)(2) = ""
      ary駒配置(20)(2) = ""
    Case "四枚落ち"
      ary駒配置(14)(2) = ""
      ary駒配置(16)(2) = ""
      ary駒配置(18)(2) = ""
      ary駒配置(20)(2) = ""
    Case "六枚落ち"
      ary駒配置(10)(2) = ""
      ary駒配置(12)(2) = ""
      ary駒配置(14)(2) = ""
      ary駒配置(16)(2) = ""
      ary駒配置(18)(2) = ""
      ary駒配置(20)(2) = ""
    Case "八枚落ち"
      ary駒配置(6)(2) = ""
      ary駒配置(8)(2) = ""
      ary駒配置(10)(2) = ""
      ary駒配置(12)(2) = ""
      ary駒配置(14)(2) = ""
      ary駒配置(16)(2) = ""
      ary駒配置(18)(2) = ""
      ary駒配置(20)(2) = ""
    Case "十枚落ち"
      ary駒配置(2)(2) = ""
      ary駒配置(4)(2) = ""
      ary駒配置(6)(2) = ""
      ary駒配置(8)(2) = ""
      ary駒配置(10)(2) = ""
      ary駒配置(12)(2) = ""
      ary駒配置(14)(2) = ""
      ary駒配置(16)(2) = ""
      ary駒配置(18)(2) = ""
      ary駒配置(20)(2) = ""
  End Select

  DoEvents
  If arg大橋流 Then Sleep 300
  
  Dim i As Long, j As Long
  With obj将棋盤
    For i = LBound(ary駒配置) To UBound(ary駒配置)
      If ary駒配置(i)(2) <> "" Then
        .着手 ary駒配置(i)(2), Nothing, 棋譜位置(ary駒配置(i)(0), ary駒配置(i)(1)), ary駒配置(i)(3)
        If arg大橋流 Then
          Call 盤面表示
          Sleep 100
        End If

      End If
    Next
  End With
  
  If Not arg大橋流 Then Call 盤面表示
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)
  '着手してシートを更新
  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 盤面表示
  Call 選択セルを手番に移動
  Call frm棋譜.棋譜表示(obj将棋盤.棋譜履歴)
End Sub

'盤面配列をシートに表示する
Private Sub 盤面表示()
  Application.ScreenUpdating = False
  
  Dim ary盤面() As String
  ary盤面 = obj将棋盤.現在盤面
  
  '将棋盤
  Dim i As Long, j As Long
  For i = 1 To 9
    For j = 1 To 9
      With p将棋盤(i, j)
        If Right(ary盤面(i, j), 1) = "↑" Then
          '先手書式
          If .Font.Name <> cnsFont Then
            .Font.Name = cnsFont
          End If
          If .Orientation <> xlHorizontal Then
            .Orientation = xlHorizontal
          End If
        ElseIf Right(ary盤面(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(ary盤面(i, j), 1)) Then
          .Value = Trim(Left(ary盤面(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 obj将棋盤.棋譜 <> "" Then
    p棋譜.Value = obj将棋盤.棋譜
    p手数.Value = obj将棋盤.手数
    '着手した後なので戦後が入れかわっている
    If obj将棋盤.先手 Then
      p後手時間.Value = obj将棋盤.消費時間
    Else
      p先手時間.Value = obj将棋盤.消費時間
    End If
  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先選択) = e場所.将棋盤 Then
    If 選択場所(arg元選択) = e場所.将棋盤 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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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 = "MS Pゴシック"
    .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

Public obj親 As cls将棋進行
Private obj棋譜 As cls棋譜
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
  Set obj棋譜 = New cls棋譜
End Sub

Private Sub Class_Terminate()
  Set pCol盤面 = Nothing
  Set pCol棋譜 = Nothing
  Set obj棋譜 = 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 Collection
  Set 棋譜履歴 = obj棋譜.棋譜履歴
End Property


Public Property Get 棋譜() As String
  棋譜 = obj棋譜.棋譜
End Property


Public Property Get 棋譜最終() As String
  棋譜最終 = obj棋譜.棋譜最終
End Property


Public Property Get 消費時間() As String
  消費時間 = obj棋譜.消費時間
End Property


Public Property Get 手数() As String
  手数 = obj棋譜.手数
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先位置
      '「is成り」はByRefで今回成ったかの情報が戻される
      Me.駒(arg先位置).成り = 成り判定(arg元位置, arg先位置, is成り)
      Set Me.駒(arg元位置) = Nothing
  End Select
  
  '棋譜履歴
  If arg元位置.行 = 0 Then
    Call obj棋譜.棋譜作成(g位置(0, 0), Me.駒(arg先位置), False)
  Else
    Call obj棋譜.棋譜作成(arg元位置, Me.駒(arg先位置), is成り)
  End If

  
  '盤面履歴
  pCol盤面.Add pAry駒
  
  Call 手番交代
End Sub

Public Function 終局判定() As Boolean
  '※※※これは難しいので後回し※※※
  '持駒を含めた全ての駒を使って受けがないかの判定
End Function

'**********************************************************************
' 非公開メソッド
'**********************************************************************

Private Sub 手番交代()
  Me.先手 = Not Me.先手
End Sub

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

棋譜クラス ・・・ 今回新規作成

モジュール名:cls棋譜

Option Explicit

Public obj親 As cls将棋進行
Private pCol棋譜 As Collection
Private p先手時間 As Date
Private p後手時間 As Date
Private p最終時刻 As Date

Private Sub Class_Initialize()
  Set pCol棋譜 = New Collection
  p先手時間 = 0
  p後手時間 = 0
  p最終時刻 = Now()
End Sub

Private Sub Class_Terminate()
  Set pCol棋譜 = Nothing
End Sub

Public Property Get 先手() As Boolean
  '奇数手が先手:1→True
  先手 = CBool(pCol棋譜.Count Mod 2 = 1)
End Property

Public Property Get 棋譜履歴() As Collection
  Set 棋譜履歴 = pCol棋譜
End Property

Public Property Get 棋譜() As String
  On Error Resume Next
  If pCol棋譜.Count = 0 Then Exit Property
  棋譜 = Split(Trim(pCol棋譜(pCol棋譜.Count)), " ")(1)
  棋譜 = IIf(Me.先手, "▲", "△") & 棋譜
End Property

Public Property Get 棋譜最終() As String
  On Error Resume Next
  棋譜最終 = pCol棋譜(pCol棋譜.Count)
End Property

Public Property Get 消費時間() As String
  On Error Resume Next
  If pCol棋譜.Count = 0 Then Exit Property
  消費時間 = Split(pCol棋譜(pCol棋譜.Count), "/")(1)
  消費時間 = Replace(消費時間, ")", "")
End Property

Public Property Get 手数() As String
  手数 = pCol棋譜.Count
End Property

'棋譜はKIF形式で作成
'###1 5ニ銀成(43) (mm:ss/hh:mm:ss)
Public Function 棋譜作成(ByVal arg元位置 As g位置, _
             ByVal arg駒先 As cls駒, _
             ByRef arg成り As Boolean) As String
  Dim ary(1 To 15) As String
  Dim n4 As String * 4
  RSet n4 = Format(pCol棋譜.Count + 1, "0")
  ary(1) = n4
  ary(2) = " "
  ary(3) = StrConv(10 - arg駒先.駒位置.列, vbWide)
  ary(4) = WorksheetFunction.Text(arg駒先.駒位置.行, "[DBNum1]0")
  ary(5) = arg駒先.通常名称
  If arg元位置.行 = 0 Then
    ary(6) = "打"
    ary(7) = ""
    ary(8) = ""
    ary(9) = ""
    ary(10) = "  "
  Else
    ary(6) = IIf(arg成り, "成", "")
    ary(7) = "("
    ary(8) = 10 - arg元位置.列
    ary(9) = arg元位置.行
    ary(10) = ")" & IIf(ary(6) = "", " ", "")
  End If
  ary(11) = " ("
  ary(12) = Format(Now() - p最終時刻, "h:mm:ss")
  ary(13) = "/"
  If Me.先手 Then
    p先手時間 = Format(p先手時間 + ary(12), "h:mm:ss")
    ary(14) = Format(p先手時間, "h:mm:ss")
  Else
    p後手時間 = Format(p後手時間 + ary(12), "h:mm:ss")
    ary(14) = Format(p後手時間, "h:mm:ss")
  End If
  ary(15) = ")"
  
  棋譜作成 = Join(ary, "")
  pCol棋譜.Add 棋譜作成
  p最終時刻 = Now()
End Function

ここまでのVBAコードを組み込んだExcelファイルは以下からダウンロード出来ます。

Excel将棋の目次

№1. Excel将棋:マクロVBAの学習用
Excelで将棋を作ってみましょう。今やコンピューター将棋はプロをしのぐ強さです。しかし、Excelでそのようなソフトを作ろうと言うのではありません。と言いますか、残念ながら私には作れません、、、ExcelマクロVBAの学習素材として将棋を作ってみましょう。
№2. Excel将棋:クラスの設計
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、VBAクラスの設計になります。設計といっても、どのようなプロパティ・メソッドをもたせるかといった概要だけです。
№3. Excel将棋:駒クラスの作成
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、駒クラスの作成になります。駒クラスに必要な部品クラスとして、位置クラスと移動クラスを先に作成してから駒クラスの作成に進みます。
№4. Excel将棋:駒クラスの単体テスト
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、前回の№3.Excel将棋:駒クラスの作成、この単体テストになります。駒クラスは、今後作成していく駒台クラス、将棋盤クラスで使用するものです。
№5. Excel将棋:駒台クラスの作成&単体テスト
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、駒台クラスの作成と単体テストになります。作成するクラス全体の設計は、№2.Excel将棋:クラスの設計、こちらを参照してください。
№6. Excel将棋:位置クラスをデフォルトインスタンスに変更
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、前に作った位置クラスをデフォルトインスタンスに変更します。作成するクラス全体の設計は、№2.Excel将棋:クラスの設計、こちらを参照してください。
№7. Excel将棋:将棋盤クラスの作成&単体テスト
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、いよいよ将棋盤クラスを作成します。駒クラスを2次元配列(1To9,1To9)に入れて将棋盤全体を管理します。
№8. Excel将棋:将棋進行クラスの作成
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、シートとやり取りする将棋進行クラスを作成します。ここまでは、作成したクラスのテスト実行用のVBAを別途作成し、結果をイミディエイトウィンドウに表示して確認していました。
№9. Excel将棋:駒を動かす
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、駒を動かします。駒を動かせるように将棋進行クラスを拡張します。将棋進行クラスの完成はまだまだこれからですが、駒を動かせるようになるとゲームらしくなってきます。
№10. Excel将棋:相手の駒を取る、持ち駒を打つ
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、相手の駒を取ったり、持駒を打ったりできるようにします。取った駒は駒台へ移し、駒台から駒を選んで打てるようにします。
№11. Excel将棋:駒を成る
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、駒を成れるようにします。ただし、将棋では成らない選択も出来ますので、成れるタイミングで成るか成らないかを選択できるようにします。
№12. Excel将棋:棋譜をユーザーフォームに表示する
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、ユーザーフォームを作成し、初手からの棋譜を表示できるようにします。シート操作ができるように、ユーザーフォームはモードレスで表示します。
№13. Excel将棋:棋譜選択でその時点の盤面に戻す
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、棋譜フォームの棋譜を選択することで、その時点の盤面に戻す機能を実装します。さらに、その時点から指し継ぐこともできるようにします。
№14. Excel将棋:棋譜ファイルの出力と読込自動再生
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、KIF形式の棋譜ファイルの出力と、KIF形式の棋譜ファイルを読み込んで初手から終局までを自動再生させます。
№15. Excel将棋:反則(禁じ手)判定
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、反則(禁じ手)の判定を入れます。禁じ手は指し手そのものが出来ないようにします。※クラス名、プロシージャー名、変数名に日本語を使用しています。
№16. Excel将棋:終局(詰み)判定と打ち歩詰め
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、前回の反則(禁じ手)の続きで「打ち歩詰め」を実装します。打ち歩詰めを判定するには、そもそも「詰み」の判定が必要です。
№17. Excel将棋:千日手と連続王手の千日手
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。今回は、千日手と反則の「連続王手の千日手」を実装します。千日手は、他とは違ってある局面だけでは判定できません。
№18 Excel将棋:ひとまず完成、これまでとこれから
Excelで将棋を作ってみましょう。人vs人で動かしてゲームとして成立するところまでが当面の目標です。前回でひとまず当初目標の人vs人で動かしてゲームとして成立するところまでできました。連載の途中で、急遽棋譜の出力と読み込んで自動再生も作成しました。
№19 Excel将棋:棋譜ファイルから対局一覧作成
Excelで将棋を作るシリーズの当初目標の、人vs人で動かしてゲームとして成立するところまでは完成しました。今回は機能拡張として、棋譜ファイルを読み込み対局一覧を作成します。複数の棋譜ファイルも一度に処理できるようにしています。



新着記事NEW ・・・新着記事一覧を見る

import文(パッケージ・モジュールのインポート)|Python入門(9月24日)
例外処理(try文)とexception一覧|Python入門(9月23日)
リスト内包表記|Python入門(9月22日)
Pythonの引数は参照渡しだが・・・|Python入門(9月21日)
lambda(ラムダ式、無名関数)と三項演算子|Python入門(9月20日)
関数内関数(関数のネスト)とスコープ|Python入門(9月18日)
関数の定義(def文)と引数|Python入門(9月18日)
組み込み関数一覧|Python入門(9月17日)
辞書(dict型)|Python入門(9月16日)
入力規則への貼り付けを禁止する|VBA技術解説(9月16日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ