ExcelとVBAでミニゲーム(2048)を作成する

2048は面白くて、癖になりやすいミニゲームです。多くの読者が好きだと思います。Excelの強力なVBAを使用して2048ミニゲームを開発すれば、遊ぶ体験がまた違うでしょう。

インターフェースの設定

最初にゲームインターフェスを設定します。最初の4行を選択し、行の高さを50に設定します。この場合、セルはほぼ正方形です。次には、罫線を4 * 4セルに追加してから、外側の罫線を太い罫線に設定します。フォントをMicrosoftYahei、太字、中央揃えに変更します。6行目に、列AにSCORE、列CにMOVESを両方とも太字で記述します。

通常、2048のようなゲームはステートマシンで実装する必要があります。つまり、プログラムはゲームが終了するまで無期限に実行されます。このメソッドはExcelには適していません。ワークシートに付属のWorksheet_Selection Changeメソッドを使用して、キーボードの状態を取得し、ゲームの進みをより便利にします。

初期状態

まず、ゲームの初期状態を作りましょう。ゲーム変数は少ない状態です。ゲームの記録と操作には、4*4の2次元配列が必要です。score変数はscoreを記録し、moves変数はステップ数を記録します。初期状態では、すべて0にします。もちろん、最高得点を追加することもできますが、Excelセルの最高得点はいつでも変更できることを考えると、ほとんど意味がありません。

ここではステートマシンは使用されておらず、オブジェクト指向プログラミングにはクラスモジュールが使用されていないため、代わりにグローバル変数が使用されます。

Public numAreaArr
Public score As Double
Public moves As Integer

Public Sub Reset()

ReDim numAreaArr(1 To 4, 1 To 4) As Integer
score = 0
moves = 0

End Sub

Public numAreaArr
Public score As Double
Public moves As Integer

Public Sub Reset()

ReDim numAreaArr(1 To 4, 1 To 4) As Integer
score = 0
moves = 0

End Sub

これは変数の初期状態であり、セルに出力する必要があるため、出力メソッドが必要です。

Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer)
'インターフェス出力
        
Sheet1.Range("A1:D4") = numArr
Sheet1.Cells(6, 2) = score
Sheet1.Cells(6, 4) = moves

End Sub

ゲームが開始する時に、ゲームのインターフェス上に2つの乱数があります。空白の区域に2または4の数字をランダムに生成するメソッドが必要です。 2と4の確率比は9:1です。

Public Sub Spawn()
'乱数

Dim newElement%, n%, i%, j%
newElement = 2

Randomize (Timer)
t = 100 * Rnd()
If t > 90 Then newElement = 4

n = Int(16 * Rnd())
i = Int(n / 4) + 1
j = n Mod 4 + 1

Do While (numAreaArr(i, j) <> 0)
  n = Int(16 * Rnd())
  i = Int(n / 4) + 1
  j = n Mod 4 + 1
Loop

numAreaArr(i, j) = newElement
Call Output(numAreaArr, score, moves)

End Sub

次に、Resetメソッドの最後に次のコードを追加します。

Call Spawn
Call Spawn
Call Output(numAreaArr, score, moves)

移動

キーボードのステータスを読み取るには、インターフェイスが必要です。Sheet1に次のコードを追加します。

#If VBA7 And Win64 Then
  Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
#Else
  Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
#End If

ここで読み取られるのはGetKeyboardStateインターフェイスであり、VBA7と64ビットのWindowsシステムでは、VBAの呼び出しメソッドがわずかに異なるため、IF判定が追加されます。具体的な使い方は次のとおりです。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim keycode(0 To 255) As Byte
GetKeyboardState keycode(0)

If keycode(37) > 127 Then Call Num_Move(0)  '左
If keycode(38) > 127 Then Call Num_Move(1)  '上
If keycode(39) > 127 Then Call Num_Move(2)  '右
If keycode(40) > 127 Then Call Num_Move(3)  '下

Sheet1.Cells(4, 4).Select

Application.EnableEvents = True
Application.ScreenUpdating = True

If Game_Over Then MsgBox "ゲームが終了!", , "Game Over"
End Sub

まず、ワークシートのイベントと画面の更新をブロックして、反復を回避し、画面表示を高速化します。次に、keycode配列を使用してキーボードの状態を記録します。配列インデックスの37〜40は、キーボードの左、上、右、下に対応し、それに応じて、状態0〜3をNum_Moveメソッドに渡します。最後に、ブロックされたイベントが復元され、Game_Over関数を使用してゲームが終了したかどうかを判定します。

Num_Moveメソッドは、画面にある数値を移動するメソッドです。まず、その流れを分析しましょう。

1、画面上の数値を取得します。

2、移動できるかどうかを判断し、移動できない場合はメソッドを終了します。

3、最初にすべての数値をその方向の最後に移動し、次に隣接する同じ数値をマージしてから、マージされた数値を最後に移動します。

4、新しい乱数を追加し、画面に出力します。

分析した後、段階的に解決していきましょう。

1、データを取得する

まずは、画面上の数値を取得するメソッドです。出力メソッドと正反対です。

Public Sub Get_Data()

numAreaArr = Sheet1.Range("A1:D4")
score = Sheet1.Cells(6, 2)
moves = Sheet1.Cells(6, 4)

End Sub

2、移動できるかどうかを判定する

次に、移動できるかどうかを判断する方法です。下方向への移動を例にします。0以外の数値より下のセルの値は0で、下のセルと同じで、移動できることを意味します。コードは次のように表示されます。

Public Function Move_Is_Possible(ByVal direction As Integer) As Boolean

Move_Is_Possible = False

Dim numArr
numArr = numAreaArr

'下に確認する
For i = 1 To 3
  For j = 1 To 4
    If numArr(i, j) <> 0 And numArr(i + 1, j) = 0 Then Move_Is_Possible = True: Exit Function
    If numArr(i, j) <> 0 And numArr(i, j) = numArr(i + 1, j) Then Move_Is_Possible = True: Exit Function
  Next j
Next i

End Function

ここでの問題は、上、下、左、右方向の判定を別々に書くと、面倒で賢くないです。移動、縮小と数値マージの場合、上、下、左、右の4つの状況で記述する必要があることを考えると、まだいくつかのより便利なメソッドを考えています。(実際にはありません)

配列を処理しているので、行列を使ったいくつかのメソッドを考えることができます。例えば、右への判定を検証するには、配列を転置してから下に判定します。左への判定を検証するには、配列を反転して右に判定し、前の質問に戻ります。上への判定を検証するには、配列を反転して左に判定し、前の質問に戻ることができます。 未知の問題から既知の問題への変換は、数学の削減です。

そのため、配列の転置関数と反転関数のみが必要になります。コードは次のように表示されます。

Public Function Transpose(ByVal numArr) As Variant
'転置

Dim newArr(1 To 4, 1 To 4) As Integer
For i = 1 To 4
  For j = 1 To 4
    newArr(i, j) = numArr(j, i)
  Next j
Next i
Transpose = newArr

End Function

Public Function Invert(ByVal numArr) As Variant
'反転

Dim newArr(1 To 4, 1 To 4) As Integer
For i = 1 To 4
  For j = 1 To 4
    newArr(i, j) = numArr(i, 5 - j)
  Next j
Next i
Invert = newArr

End Function

この時には、キーボード状態操作で配列を変更する関数が必要です。direction引数の0、1、2、3がそれぞれ方向の左、上、右、下に対応します。配列操作の方法は前述のとおりです。右が下に変更することは転置で、左が下に変更することは反転→転置で、上が下に変更することは転置→反転→転置です。

Public Function Arr_Change(ByVal numArr, ByVal direction As Integer, Optional status As Integer = 0) As Variant

If direction = 0 And status = 1 Then
  Arr_Change = Invert(Transpose(numArr))
  Exit Function
End If

Select Case direction
  Case 0
    numArr = Transpose(Invert(numArr))
  Case 1
    numArr = Transpose(Invert(Transpose(numArr)))
  Case 2
    numArr = Transpose(numArr)
End Select
Arr_Change = numArr

End Function

オプションの引数statusを追加する必要がある理由を説明します。このメソッドは、配列を移動、縮小、マージするときにも使用されると言いましたが、使用後に配列を画面に出力するように復元する必要があります。 方向1と2に対応する操作は対称であるため、復元時に同じメソッドが使用されます。方向0での操作は対称ではないため、出力前に配列を復元するメソッドを呼び出すときに、方向0の場合は、status引数によって反対の操作をします。

ここで、Arr_Change関数をMove_Is_Possible関数に追加して、numArr変数の割り当てが次のようになります。

numArr = Arr_Change(numAreaArr, direction)

方向で判定できます。

3、移動の操作

上記のメソッドによって、下方向への移動を考えるだけでいいです。

まずは、収縮を実行し、配列を下から上に読み取ります。0であるセルがある場合は、この列にある下から上、最初の0ではないセルと交換します。コードは次のように表示されます。

Public Function Tighten(ByVal numArr) As Variant
'下に収縮する

For i = 4 To 1 Step -1
  For j = 1 To 4
  
    If numArr(i, j) = 0 Then
    
      For k = i - 1 To 1 Step -1
        If numArr(k, j) <> 0 Then
          numArr(i, j) = numArr(k, j)
          numArr(k, j) = 0
          Exit For
        End If
      Next k
      
    End If
    
  Next j
Next i
Tighten = numArr

End Function

次に、マージを実行し、下から上に読み取ります。0ではない、または前の行と同じ数値がある場合は、その行に追加し、前の行を0に戻します。同時に、マージした数値をSCOREに追加します。コードは次のように表示されます。

Public Function Merge(ByVal numArr) As Variant
'下にマージする

For i = 4 To 2 Step -1
  For j = 1 To 4
  
    If numArr(i, j) <> 0 And numArr(i, j) = numArr(i - 1, j) Then
      numArr(i, j) = numArr(i, j) * 2
      score = score + numArr(i, j)
      numArr(i - 1, j) = 0
    End If
    
  Next j
Next i
Merge = numArr

End Function

これらの関数を使用して、Num_Moveメソッドを組み合わせることができます。

Public Sub Num_Move(ByVal direction As Integer)

Call Get_Data

If Move_Is_Possible(direction) = False Then Exit Sub

numAreaArr = Arr_Change(numAreaArr, direction)
numAreaArr = Tighten(Merge(Tighten(numAreaArr)))
numAreaArr = Arr_Change(numAreaArr, direction, 1)

moves = moves + 1
Call Spawn
Call Output(numAreaArr, score, moves)

End Sub

ゲームが終了

ゲームが終了時の判定関数は、すべての方向をトラバースし、Move_Is_PossibleがFalseを返す場合、Trueを返します。コードは次のとおりです。

Public Function Game_Over() As Boolean

Call Get_Data
Game_Over = True

For i = 0 To 3
  If Move_Is_Possible(i) Then Game_Over = False: Exit Function
Next i

End Function

画面の最適化

上記のコードはゲームの基本機能を実行できますが、黒白の2048は私たちのニーズを満たしていません。著者はコードを書くよりも時間がかかって、ゲームの元の配色を見つけ、それをOutputメソッドに追加しました。

最適化の内容は次のとおりです。

1、0から4096までのセルに異なる背景色を指定します。大きい方の数値は、4096と同じです。

2、0のセルに同じフォントの色と背景色を指定し、2と4は黒、その他の数字は白にします。

3、 4桁以上のフォントサイズを16に調整し、列幅を常に8.38に保ちます。

4、ボタンを挿入し、Resetメソッドを呼び出して、ゲームを再開できるようにします。

Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer)
'画面の出力

Dim index%, redArr, greenArr, blueArr
redArr = Array(204, 238, 238, 243, 243, 248, 249, 239, 239, 239, 239, 239, 95)
greenArr = Array(192, 228, 224, 177, 177, 149, 94, 207, 207, 203, 199, 195, 218)
blueArr = Array(179, 218, 198, 116, 116, 90, 50, 108, 99, 82, 57, 41, 147)

For i = 1 To 4
  For j = 1 To 4
    '背景色インデックス
    If numArr(i, j) = 0 Then
      index = 0
    ElseIf numArr(i, j) <= 4096 Then
      index = Log(numArr(i, j)) / Log(2)
    Else
      index = 11
    End If

'フォントの色
    If numArr(i, j) = 0 Then
      Sheet1.Cells(i, j).Font.Color = RGB(redArr(index), greenArr(index), blueArr(index))
    ElseIf numArr(i, j) <= 4 Then
      Sheet1.Cells(i, j).Font.Color = vbBlack
    Else
      Sheet1.Cells(i, j).Font.Color = vbWhite
    End If
    
    If numArr(i, j) >= 1024 Then
      Sheet1.Cells(i, j).Font.Size = 16
    Else
      Sheet1.Cells(i, j).Font.Size = 20
    End If
    Sheet1.Cells(i, j).Interior.Color = RGB(redArr(index), greenArr(index), blueArr(index))
  Next j
Next i
        
Sheet1.Range("A1:D4") = numArr
Sheet1.Range("A:D").ColumnWidth = 8.38
Sheet1.Cells(6, 2) = score
Sheet1.Cells(6, 4) = moves

End Sub

上記では、Excelバージョン2048が作成しており、完全なコードは通常どおり付録にあり、直接コピーして貼り付けることができます。

付録:ワークシートコード

Public numAreaArr
Public score As Double
Public moves As Integer

Public Sub Get_Data()

numAreaArr = Sheet1.Range("A1:D4")
score = Sheet1.Cells(6, 2)
moves = Sheet1.Cells(6, 4)

End Sub


Public Sub Num_Move(ByVal direction As Integer)

Call Get_Data

'Debug.Print Move_Is_Possible(direction)
If Move_Is_Possible(direction) = False Then Exit Sub

numAreaArr = Arr_Change(numAreaArr, direction)
numAreaArr = Tighten(Merge(Tighten(numAreaArr)))
numAreaArr = Arr_Change(numAreaArr, direction, 1)

moves = moves + 1
Call Spawn
Call Output(numAreaArr, score, moves)

End Sub

Public Function Merge(ByVal numArr) As Variant
'下にマージする

For i = 4 To 2 Step -1
  For j = 1 To 4
  
    If numArr(i, j) <> 0 And numArr(i, j) = numArr(i - 1, j) Then
      numArr(i, j) = numArr(i, j) * 2
      score = score + numArr(i, j)
      numArr(i - 1, j) = 0
    End If
    
  Next j
Next i
Merge = numArr

End Function

Public Function Tighten(ByVal numArr) As Variant
'下に収縮する

For i = 4 To 1 Step -1
  For j = 1 To 4
  
    If numArr(i, j) = 0 Then
    
      For k = i - 1 To 1 Step -1
        If numArr(k, j) <> 0 Then
          numArr(i, j) = numArr(k, j)
          numArr(k, j) = 0
          Exit For
        End If
      Next k
      
    End If
    
  Next j
Next i
Tighten = numArr

End Function
Public Function Arr_Change(ByVal numArr, ByVal direction As Integer, Optional status As Integer = 0) As Variant

If direction = 0 And status = 1 Then
  Arr_Change = Invert(Transpose(numArr))
  Exit Function
End If

Select Case direction
  Case 0
    numArr = Transpose(Invert(numArr))
  Case 1
    numArr = Transpose(Invert(Transpose(numArr)))
  Case 2
    numArr = Transpose(numArr)
End Select
Arr_Change = numArr

End Function

Public Function Move_Is_Possible(ByVal direction As Integer) As Boolean

Move_Is_Possible = False

Dim numArr
numArr = Arr_Change(numAreaArr, direction)

'下に確認する
For i = 1 To 3
  For j = 1 To 4
    If numArr(i, j) <> 0 And numArr(i + 1, j) = 0 Then Move_Is_Possible = True: Exit Function
    If numArr(i, j) <> 0 And numArr(i, j) = numArr(i + 1, j) Then Move_Is_Possible = True: Exit Function
  Next j
Next i

End Function
Public Function Invert(ByVal numArr) As Variant
'反転

Dim newArr(1 To 4, 1 To 4) As Integer
For i = 1 To 4
  For j = 1 To 4
    newArr(i, j) = numArr(i, 5 - j)
  Next j
Next i
Invert = newArr

End Function

Public Function Transpose(ByVal numArr) As Variant
'転置

Dim newArr(1 To 4, 1 To 4) As Integer
For i = 1 To 4
  For j = 1 To 4
    newArr(i, j) = numArr(j, i)
  Next j
Next i
Transpose = newArr

End Function

Public Function Game_Over() As Boolean

Call Get_Data
Game_Over = True

For i = 0 To 3
  If Move_Is_Possible(i) Then Game_Over = False: Exit Function
Next i

End Function

Public Sub Reset()

ReDim numAreaArr(1 To 4, 1 To 4) As Integer
score = 0
moves = 0

Call Spawn
Call Spawn
Call Output(numAreaArr, score, moves)

End Sub

Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer)
'画面の出力

Dim index%, redArr, greenArr, blueArr
redArr = Array(204, 238, 238, 243, 243, 248, 249, 239, 239, 239, 239, 239, 95)
greenArr = Array(192, 228, 224, 177, 177, 149, 94, 207, 207, 203, 199, 195, 218)
blueArr = Array(179, 218, 198, 116, 116, 90, 50, 108, 99, 82, 57, 41, 147)

For i = 1 To 4
  For j = 1 To 4
    '背景色インデックス
    If numArr(i, j) = 0 Then
      index = 0
    ElseIf numArr(i, j) <= 4096 Then
      index = Log(numArr(i, j)) / Log(2)
    Else
      index = 11
End If

  'フォントの色
    If numArr(i, j) = 0 Then
      Sheet1.Cells(i, j).Font.Color = RGB(redArr(index), greenArr(index), blueArr(index))
    ElseIf numArr(i, j) <= 4 Then
      Sheet1.Cells(i, j).Font.Color = vbBlack
    Else
      Sheet1.Cells(i, j).Font.Color = vbWhite
    End If
    
    If numArr(i, j) >= 1024 Then
      Sheet1.Cells(i, j).Font.Size = 16
    Else
      Sheet1.Cells(i, j).Font.Size = 20
    End If
    Sheet1.Cells(i, j).Interior.Color = RGB(redArr(index), greenArr(index), blueArr(index))
  Next j
Next i
        
Sheet1.Range("A1:D4") = numArr
Sheet1.Range("A:D").ColumnWidth = 8.38
Sheet1.Cells(6, 2) = score
Sheet1.Cells(6, 4) = moves

End Sub

Public Sub Spawn()
'乱数

Dim newElement%, n%, i%, j%
newElement = 2

Randomize (Timer)
t = 100 * Rnd()
If t > 90 Then newElement = 4

n = Int(16 * Rnd())
i = Int(n / 4) + 1
j = n Mod 4 + 1

Do While (numAreaArr(i, j) <> 0)
  n = Int(16 * Rnd())
  i = Int(n / 4) + 1
  j = n Mod 4 + 1
Loop

numAreaArr(i, j) = newElement

End Sub
Share

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です