エクセルでテトリスを作りました！！
前からつくってみたいなあと思っていたゲームの一つで、これもなかなか時間がかかりました。
仕事終わってからだらだら作っていたら一週間くらいかかりました（工数はだいたい１人日～２人日くらい）。
ですが、思ったより簡単に作れました。エクセルで過去にオセロや将棋などつくりましたが、
毎回思うことがゲーム作りに必要なものは根気と気合です。
この記事では、作成したテトリスについて、その操作方法と作成方法についてご紹介します。
※ 作成方法したエクセルのテトリスについては下記からダウンロード可能ですので、ぜひ遊んでみてください。
操作方法
作成したテトリスの操作方法について説明します。
ゲームの開始と終了
テトリスを開始するときは「START」ボタンをクリックしますが、ゲームを終了する場合はキーボードの「Home」キーを押下します。
ゲームの開始と終了
- 「Start」ボタン : テトリスの開始
- キーボードの「Home」 : テトリスの終了
キーボード操作
操作方法
- 「←」「↑」「↓」「→」キー : ブロックの移動
- 「Ctrl」キー : ブロックの回転
- 「Home」キー : テトリスの終了
後は、いつものテトリスです。ブロックを一行そろえて消すだけです。
またテトリスには、一行ずつ消すよりもまとめて消したほうがお得というルールがありますね。今回それを下記式で表しています。
Score = Score + 100 + [消した行の数] * 300
テトリスを作った割にテトリスのポイントのつけ方がよくわからなかったので、こんな感じで付けました。
Score とは点数のことで、「Score = Score + ~ 」とは、もともとの Score の値にどんどん足していきますよということです。
例えば削除した行が１行なら Score = 400点、2行なら700点つきます（答えを知っている人は教えてほしいです）。
終了条件
前述しましたがゲームを終了する場合はキーボードの「Home」キーを押下しますが、それ以外にもテトリスが続行できない場合も終了するようにしています。
要はブロックが天井を突き抜けた状態です。このときは強制的にテトリスが終了します。
作成方法
Excel vba で作成しています。要はプログラミングして作成しました。
実際のテトリスの作成手順は下記の５つになります。この５つができればテトリスは作れます。
作成手順
- 下準備（定数と変数の定義 & レイアウトの作成）
- ブロックを描く
- ブロックの移動、回転
- ブロックが一行並べば消す
- テトリスの終了条件をつける
これだけみれば、「案外簡単そうだなあ」と思われる人もいるかもしれませんが、案外めんどくさいです。
特にめんどくさいのが、ブロックの移動、回転の処理です。では順をおって説明します。
メイン関数
作成したテトリスのメイン関数です。
処理概要を説明しますと、まず定数、変数の定義とレイアウト作成などの下準備を行います。
その後 Do While True ~ をつかって無限ループさせ、ブロックを落とすようにします。
その無限ループの処理の中で下記の処理を行います。
無限ループ内処理
- 0.3 秒ごとに一行したにブロックが移動
- その0.3秒のうちの0.1秒ごとにキーボードのイベントを取得
- ブロックが一番下までいけば、一行そろっているブロックがあるか確認し、あれば消してスコアをつける
- その後、ブロックが天井より上かどうか確認（ゲームオーバーであるか）
これだけです。天井という言い方が正しいかはわかりませんが、
ブロックが指定したセルの行よりあれば終了するようにしています（先ほど貼ったやつです）。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
'メイン Sub Tetris() Dim x As Integer Dim y As Integer Dim n As Integer Dim i As Integer Dim Block As Integer: Block = 0 Dim Next_Block As Integer: Next_Block = 0 ' 初期化 Call setting(x, y) Do While True x = START_X y = START_Y ROTATE_NUM = 0 Call setBlock(Block, Next_Block) For y = START_Y To BOTTOM_Y For n = 1 To 3 Call setEvent(x, y, Block) Application.Wait [Now() + "00:00:00.10"] Next n ' ブロックを移動できない状態ならブロックを削除 If DropBlock(x, y, Block) = False Then Call checkRowBlock Exit For End If Next y Call checkgame Loop End Sub |
次にメイン関数の処理をプロシージャにわけて説明します。
下準備（定数と変数の定義 & レイアウトの作成）
定数と変数の定義
まず初めに定数と変数の定義します。
記事作成での都合上、最初に定数と変数の定義を最初にきていますが、プログラミングをしている段階では、必要なたびにどんどん定義しています（当たり前ですが、）。
定数については、レイアウトの位置情報（何行何列目のセルに描くか）とブロックの色について定義づけしています（固定なので）。
また、変数については、ブロックの先頭セルと、テトリスのスコア、ブロックの回転数について定義しています。これらは後で説明しますのでいまは適当に流していただいて問題ありません。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
'シート名 Public Const TETRIS_SHEET As String = "Tetris" 'テトリス位置 Public Const BOTTOM_Y As Integer = 27 Public Const BOTTOM_X_LEFT As Integer = 3 Public Const BOTTOM_X_RIGHT As Integer = 15 Public Const START_X As Integer = 8 Public Const START_Y As Integer = 4 'ブロックの先頭位置 Public TOP_X_L As Integer Public TOP_X_R As Integer Public TOP_Y As Integer 'ブロックの先頭位置 Public Const NEXT_START_X As Integer = 23 Public Const NEXT_START_Y As Integer = 7 ' スコア Public Const SCORE_POSITION_X As Integer = 24 Public Const SCORE_POSITION_Y As Integer = 12 Public Score As Integer ' 回転数 Public ROTATE_NUM As Integer '色の定義 0 → 白 | 1 → 黒 Public Const NO_COLOR As Integer = 0 Public Const BLOCK1_COLOR As Integer = 3 Public Const BLOCK2_COLOR As Integer = 8 Public Const BLOCK3_COLOR As Integer = 5 Public Const BLOCK4_COLOR As Integer = 50 Public Const BLOCK5_COLOR As Integer = 46 Public Const BLOCK6_COLOR As Integer = 29 Public Const BLOCK7_COLOR As Integer = 27 |
テトリスのレイアウト
テトリスの枠のレイアウトを vba で書くようにします。
これはもし間違えてシート上のセルを消してしまった場合も問題ないようにするためです。
作成するレイアウトは、下記画像の青矢印の箇所（テトリスの周りのブロックと、次のテトリスを表示させる黒枠の箇所）です。
また、もともとブロックが描いてある場合もいったん消してきれいにするようにしています。
下記はソースコードですが、setting プロシージャがメイン関数で、その中に ①テトリスの周りのブロックと、②次のテトリスを表示させる黒枠の箇所のレイアウトの設定を行っています。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
Option Explicit ' 初期化 Sub setting(ByRef x As Integer, ByRef y As Integer) x = START_X y = START_Y Score = 0 ROTATE_NUM = 0 Application.ScreenUpdating = False Call settingTetris Call settingNextBlock Worksheets(TETRIS_SHEET).Cells(SCORE_POSITION_Y, SCORE_POSITION_X).Value = Score End Sub Private Sub settingTetris() Application.ScreenUpdating = False With Worksheets(TETRIS_SHEET).Range(Cells(START_Y, BOTTOM_X_LEFT), Cells(BOTTOM_Y, BOTTOM_X_LEFT)) .Interior.color = RGB(192, 192, 192) .Borders.LineStyle = xlContinuous End With With Worksheets(TETRIS_SHEET).Range(Cells(START_Y, BOTTOM_X_RIGHT), Cells(BOTTOM_Y, BOTTOM_X_RIGHT)) .Interior.color = RGB(192, 192, 192) .Borders.LineStyle = xlContinuous End With With Worksheets(TETRIS_SHEET).Range(Cells(BOTTOM_Y, BOTTOM_X_LEFT), Cells(BOTTOM_Y, BOTTOM_X_RIGHT)) .Interior.color = RGB(192, 192, 192) .Borders.LineStyle = xlContinuous End With Worksheets(TETRIS_SHEET).Range(Cells(1, BOTTOM_X_LEFT + 1), Cells(BOTTOM_Y - 1, BOTTOM_X_RIGHT - 1)).ClearFormats Application.ScreenUpdating = True End Sub Sub settingNextBlock() Application.ScreenUpdating = False Worksheets(TETRIS_SHEET).Range(Cells(START_Y + 1, NEXT_START_X - 1), Cells(START_Y + 4, NEXT_START_X + 3)).ClearFormats Application.ScreenUpdating = True End Sub |
ブロックを描く
テトリスのブロックは下記の７種類あるそうです。なので、これを描くようにします。
今回これらのブロックに名前をつけています。左から１、２ .... ７という数値をつけそれを Block という変数にもたせるようにしています。
ブロックの描き方についてはただセルに色と枠線をつけるだけです。
また、セルに入れる処理を毎回書くのが面倒だったので、paintColor プロシージャにまとめ、座標情報（何行何列目に入力するか）のみで描けるようにしてあります。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
Option Explicit ' ランダムにブロックを取得 Sub getRandBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) Select Case Block Case 1 Call makeBlock1(x, y) Case 2 Call makeBlock2(x, y) Case 3 Call makeBlock3(x, y) Case 4 Call makeBlock4(x, y) Case 5 Call makeBlock5(x, y) Case 6 Call makeBlock6(x, y) Case 7 Call makeBlock7(x, y) End Select Call setTopPlace(x, y, Block) End Sub ' 正方形 ブロック作成 Private Sub makeBlock1(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK1_COLOR Call paintColor(color, x + 1, y) Call paintColor(color, x + 2, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y - 1) End Sub ' 長方形 ブロック作成 Private Sub makeBlock2(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK2_COLOR If ROTATE_NUM = 0 Then Call paintColor(color, x + 2, y) Call paintColor(color, x + 2, y - 1) Call paintColor(color, x + 2, y - 2) Call paintColor(color, x + 2, y - 3) Else Call paintColor(color, x, y - 2) Call paintColor(color, x + 1, y - 2) Call paintColor(color, x + 2, y - 2) Call paintColor(color, x + 3, y - 2) End If End Sub ' L字 ブロック作成 Private Sub makeBlock3(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK3_COLOR If ROTATE_NUM = 1 Then Call paintColor(color, x, y) Call paintColor(color, x, y - 1) Call paintColor(color, x, y - 2) Call paintColor(color, x + 1, y - 2) ElseIf ROTATE_NUM = 2 Then Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y - 1) Call paintColor(color, x + 2, y) ElseIf ROTATE_NUM = 3 Then Call paintColor(color, x, y) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Else Call paintColor(color, x, y) Call paintColor(color, x + 1, y) Call paintColor(color, x + 2, y) Call paintColor(color, x, y - 1) End If End Sub ' 逆L字 ブロック作成 Private Sub makeBlock4(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK4_COLOR If ROTATE_NUM = 1 Then Call paintColor(color, x, y) Call paintColor(color, x, y - 1) Call paintColor(color, x, y - 2) Call paintColor(color, x + 1, y) ElseIf ROTATE_NUM = 2 Then Call paintColor(color, x, y) Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y - 1) ElseIf ROTATE_NUM = 3 Then Call paintColor(color, x, y - 2) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Else Call paintColor(color, x, y) Call paintColor(color, x + 1, y) Call paintColor(color, x + 2, y) Call paintColor(color, x + 2, y - 1) End If End Sub ' 山 ブロック作成 Private Sub makeBlock5(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK5_COLOR If ROTATE_NUM = 1 Then Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Call paintColor(color, x + 2, y - 1) ElseIf ROTATE_NUM = 2 Then Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y - 1) Call paintColor(color, x + 1, y) ElseIf ROTATE_NUM = 3 Then Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Else Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Call paintColor(color, x + 2, y - 1) End If End Sub ' Z字 ブロック作成 Private Sub makeBlock6(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK6_COLOR If ROTATE_NUM = 1 Then Call paintColor(color, x, y) Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 1, y - 2) Else Call paintColor(color, x, y - 1) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y) End If End Sub ' 逆Z字 ブロック作成 Private Sub makeBlock7(ByVal x As Integer, ByVal y As Integer) Const color As Integer = BLOCK7_COLOR If ROTATE_NUM = 1 Then Call paintColor(color, x, y - 1) Call paintColor(color, x, y - 2) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Else Call paintColor(color, x, y) Call paintColor(color, x + 1, y) Call paintColor(color, x + 1, y - 1) Call paintColor(color, x + 2, y - 1) End If End Sub ' セルの色つける Private Sub paintColor(ByVal color As Integer, ByVal x As Integer, ByVal y As Integer) Application.ScreenUpdating = False With Worksheets(TETRIS_SHEET).Cells(y, x) .Borders.LineStyle = xlContinuous .Interior.ColorIndex = color End With Application.ScreenUpdating = True End Sub |
具体的には 1 ~ 7 のうちのランダムな数値を取得し、取得した値からブロックを生成するようにします。
例えば 3 という数値が取得したらブロック３を出力するようにします。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
' 落とすブロックのセット Private Sub setBlock(ByRef Block As Integer, ByRef Next_Block As Integer) Randomize Call settingNextBlock If Block = 0 Then Block = Int(7 * Rnd + 1) Else Block = Next_Block End If Next_Block = Int(7 * Rnd + 1) Select Case Next_Block Case 1 Call getRandBlock(NEXT_START_X - 1, NEXT_START_Y, Next_Block) Case 2 Call getRandBlock(NEXT_START_X - 1, NEXT_START_Y + 1, Next_Block) Case 5 Call getRandBlock(NEXT_START_X, NEXT_START_Y + 1, Next_Block) Case Else Call getRandBlock(NEXT_START_X, NEXT_START_Y, Next_Block) End Select Call getRandBlock(START_X, START_Y, Block) End Sub |
またブロックの削除処理もつくっています。
これはブロックを移動させるときに必要な処理です（後で説明します）。
ブロックの削除の仕方ですが、簡単に指定した行と列の書式を削除しているだけです。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
Option Explicit ' ランダムにブロックを取得 Sub deleteRandBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) Select Case Block Case 1 Call deleteBlock1(x, y) Case 2 Call deleteBlock2(x, y) Case 3 Call deleteBlock3(x, y) Case 4 Call deleteBlock4(x, y) Case 5 Call deleteBlock5(x, y) Case 6 Call deleteBlock6(x, y) Case 7 Call deleteBlock7(x, y) End Select End Sub ' 正方形 ブロック削除 Private Sub deleteBlock1(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 3 Call deleteFormat(x + 1, y) Call deleteFormat(x + 2, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y - 1) End Sub ' 長方形 ブロック削除 Private Sub deleteBlock2(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 8 If ROTATE_NUM = 0 Then Call deleteFormat(x + 2, y) Call deleteFormat(x + 2, y - 1) Call deleteFormat(x + 2, y - 2) Call deleteFormat(x + 2, y - 3) Else Call deleteFormat(x, y - 2) Call deleteFormat(x + 1, y - 2) Call deleteFormat(x + 2, y - 2) Call deleteFormat(x + 3, y - 2) End If End Sub ' L字 ブロック削除 Private Sub deleteBlock3(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 5 If ROTATE_NUM = 1 Then Call deleteFormat(x, y) Call deleteFormat(x, y - 1) Call deleteFormat(x, y - 2) Call deleteFormat(x + 1, y - 2) ElseIf ROTATE_NUM = 2 Then Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y - 1) Call deleteFormat(x + 2, y) ElseIf ROTATE_NUM = 3 Then Call deleteFormat(x, y) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Else Call deleteFormat(x, y) Call deleteFormat(x + 1, y) Call deleteFormat(x + 2, y) Call deleteFormat(x, y - 1) End If End Sub ' 逆L字 ブロック削除 Private Sub deleteBlock4(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 50 If ROTATE_NUM = 1 Then Call deleteFormat(x, y) Call deleteFormat(x, y - 1) Call deleteFormat(x, y - 2) Call deleteFormat(x + 1, y) ElseIf ROTATE_NUM = 2 Then Call deleteFormat(x, y) Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y - 1) ElseIf ROTATE_NUM = 3 Then Call deleteFormat(x, y - 2) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Else Call deleteFormat(x, y) Call deleteFormat(x + 1, y) Call deleteFormat(x + 2, y) Call deleteFormat(x + 2, y - 1) End If End Sub ' 山 ブロック削除 Private Sub deleteBlock5(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 46 If ROTATE_NUM = 1 Then Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Call deleteFormat(x + 2, y - 1) ElseIf ROTATE_NUM = 2 Then Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y - 1) Call deleteFormat(x + 1, y) ElseIf ROTATE_NUM = 3 Then Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Else Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Call deleteFormat(x + 2, y - 1) End If End Sub ' Z字 ブロック削除 Private Sub deleteBlock6(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 29 If ROTATE_NUM = 1 Then Call deleteFormat(x, y) Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 1, y - 2) Else Call deleteFormat(x, y - 1) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y) End If End Sub ' 逆Z字 ブロック削除 Private Sub deleteBlock7(ByVal x As Integer, ByVal y As Integer) Const color As Integer = 27 If ROTATE_NUM = 1 Then Call deleteFormat(x, y - 1) Call deleteFormat(x, y - 2) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Else Call deleteFormat(x, y) Call deleteFormat(x + 1, y) Call deleteFormat(x + 1, y - 1) Call deleteFormat(x + 2, y - 1) End If End Sub ' セルの書式の削除 Private Sub deleteFormat(ByVal x As Integer, ByVal y As Integer) Application.ScreenUpdating = False With Worksheets(TETRIS_SHEET).Cells(y, x) .ClearFormats End With Application.ScreenUpdating = True End Sub |
ブロックの移動、回転
ブロックの移動は「←」「↑」「↓」「→」のキーボード入力で行っています。
「←」「↑」「↓」「→」のキーボード入力のイベントを検知したときに、下記プロシージャが呼び出されるようにしてあります。
ブロックの移動についてですが、移動前のブロックの書式を削除→次のブロックに色をつけるというふたつの処理を行っています。
前章「ブロックを描く」で説明しました、「ブロックを描く」処理と「ブロックを削除」処理の二つを呼び出して処理させています。
またブロックを移動させるときの注意点は移動範囲です。
当然ですがブロックが壁を貫いたり、底を突き抜けて動いていたらテトリスになりません。
ですので今回はブロックごとに先頭セルをもたせてあり、先頭セルの次の行ももしくは列のセルの色が白色（背景色）でならブロックが移動できるようにしています。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
Option Explicit #If VBA7 Then '32bit PC Private Declare Sub Sleep Lib "kernel32.dll" (ByVal ms As Long) Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long #Else '64bit PC Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal ms As LongPtr) Private Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As LongPtr) As Long #End If ' キーボードイベント検知 Sub setEvent(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) ' 左矢印 If GetAsyncKeyState(vbKeyLeft) <> 0 Then Call moveLeft(x, y, Block) End If ' 右矢印 If GetAsyncKeyState(vbKeyRight) <> 0 Then Call moveRight(x, y, Block) End If ' 下矢印 If GetAsyncKeyState(vbKeyDown) <> 0 Then Call moveDown(x, y, Block) End If ' Ctrl 回転 If GetAsyncKeyState(vbKeyControl) <> 0 Then Call rotateBlock(x, y, Block) End If ' Homeボタン 終了 If GetAsyncKeyState(vbKeyHome) <> 0 Then MsgBox "Game Fin!" & Chr(13) & "Score : " & Score End End If End Sub ' 右に移動 Private Sub moveRight(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) If TOP_X_R <= BOTTOM_X_RIGHT And checkColor_Right(TOP_X_R, y, Block) = True Then Call deleteRandBlock(x, y, Block) x = x + 1 Call getRandBlock(x, y, Block) End If End Sub ' 左に移動 Private Sub moveLeft(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) If TOP_X_L > BOTTOM_X_LEFT And checkColor_Left(TOP_X_L, y, Block) = True Then Call deleteRandBlock(x, y, Block) x = x - 1 Call getRandBlock(x, y, Block) End If End Sub ' 下に移動 Private Sub moveDown(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) If TOP_Y < BOTTOM_Y And checkColor_Down(x, TOP_Y, Block) = True Then Call deleteRandBlock(x, y, Block) y = y + 1 Call getRandBlock(x, y, Block) End If End Sub ' 自然にブロックが落ちる動き Function DropBlock(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) As Boolean If TOP_Y < BOTTOM_Y And checkColor_Down(TOP_X_R, TOP_Y, Block) = True Then Call deleteRandBlock(x, y, Block) Call getRandBlock(x, y + 1, Block) DropBlock = True Else DropBlock = False End If End Function ' 隣の色の確認 置ける箇所ならTrue 左方向 Function checkColor_Left(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean checkColor_Left = False Select Case Block Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 2 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 3) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ Then checkColor_Left = True End If End Select Case 3 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ Then checkColor_Left = True End If Case 2 If checkNoColor(TOP_X_L + 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 3 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L, TOP_Y - 2) = True _ Then checkColor_Left = True End If End Select Case 4 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ Then checkColor_Left = True End If Case 2 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 3 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ Then checkColor_Left = True End If End Select Case 5 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ Then checkColor_Left = True End If Case 2 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 3 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L, TOP_Y - 2) = True _ Then checkColor_Left = True End If End Select Case 6 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L, TOP_Y - 2) = True _ Then checkColor_Left = True End If End Select Case 7 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_L, TOP_Y - 1) = True _ Then checkColor_Left = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y - 2) = True _ Then checkColor_Left = True End If End Select End Select End Function ' 隣の色の確認 置ける箇所ならTrue 右方向 Function checkColor_Right(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean checkColor_Right = False Select Case Block Case 1 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 2 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 3) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L - 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y) = True _ Then checkColor_Right = True End If End Select Case 3 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R - 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ Then checkColor_Right = True End If Case 2 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 3 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ Then checkColor_Right = True End If End Select Case 4 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R, TOP_Y - 2) = True _ Then checkColor_Right = True End If Case 2 If checkNoColor(TOP_X_R - 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 3 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ Then checkColor_Right = True End If End Select Case 5 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R, TOP_Y - 2) = True _ Then checkColor_Right = True End If Case 2 If checkNoColor(TOP_X_R, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 3 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ Then checkColor_Right = True End If End Select Case 6 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 2) = True _ Then checkColor_Right = True End If End Select Case 7 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_R, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ Then checkColor_Right = True End If Case 1 If checkNoColor(TOP_X_R + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R + 1, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R, TOP_Y - 2) = True _ Then checkColor_Right = True End If End Select End Select End Function ' 隣の色の確認 置ける箇所ならTrue 下方向 Function checkColor_Down(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) As Boolean checkColor_Down = False Select Case Block Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 2 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 2, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If End Select Case 3 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y - 1) = True _ Then checkColor_Down = True End If Case 2 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 3 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If End Select Case 4 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 2 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y) = True _ Then checkColor_Down = True End If Case 3 If checkNoColor(TOP_X_L, TOP_Y - 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If End Select Case 5 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y) = True _ Then checkColor_Down = True End If Case 2 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y) = True _ Then checkColor_Down = True End If Case 3 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If End Select Case 6 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y) = True _ Then checkColor_Down = True End If End Select Case 7 Select Case ROTATE_NUM Case 0 If checkNoColor(TOP_X_L, TOP_Y + 1) = True _ And checkNoColor(TOP_X_L + 1, TOP_Y + 1) = True _ And checkNoColor(TOP_X_R, TOP_Y) = True _ Then checkColor_Down = True End If Case 1 If checkNoColor(TOP_X_L, TOP_Y) = True _ And checkNoColor(TOP_X_R, TOP_Y + 1) = True _ Then checkColor_Down = True End If End Select End Select End Function ' 指定セルの色がデフォルトの色か デフォルトの色ならTrue Public Function checkNoColor(ByVal x As Integer, ByVal y As Integer) As Boolean Dim color color = Worksheets(TETRIS_SHEET).Cells(y, x).Interior.color If color = RGB(255, 255, 255) Then checkNoColor = True Else checkNoColor = False End If End Function |
つぎにブロックの回転ですが（これ結構悩んだんですが）一番早いのがブロックごとにパターンをつくってセルに描くことです。
順に説明しますと、ブロックの回転は「Ctrl」キーで回転するようにしていますが、
その「Ctrl」キーの入力イベントを検知した後、「Ctrl」キーが押された回数を変数 ROTATE_NUM にもたせます。
例えば「Ctrl」キーが２回入力されれば ROTATE_NUM = 2となります。そして、ブロック名が「2」で ROTATE_NUM = 2 なら「こう描く！」と決めておきます。
※具体的には下記表のようにパターン化します。
あとは上記表の組み合わせをガリガリ書くだけです（これが書き間違えなどあって大変でしたね、、、）。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
Option Explicit ' ブロック 回転 Sub rotateBlock(ByRef x As Integer, ByRef y As Integer, ByRef Block As Integer) Dim tmp_ROTATE_NUM Call deleteRandBlock(x, y, Block) Select Case Block Case 2, 6, 7 If ROTATE_NUM = 0 Then tmp_ROTATE_NUM = ROTATE_NUM + 1 Else tmp_ROTATE_NUM = 0 End If Case 3, 4, 5 If ROTATE_NUM <> 3 Then tmp_ROTATE_NUM = ROTATE_NUM + 1 Else tmp_ROTATE_NUM = 0 End If End Select ' 回転できるか確認 If checkRotateBlock(x, y, Block) = True Then ' 端っこで回転させる場合、ブロックをずらす If Block = 2 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 0 Then x = BOTTOM_X_RIGHT - 4 If Block = 2 And TOP_X_R <= BOTTOM_X_LEFT + 2 And ROTATE_NUM = 0 Then x = BOTTOM_X_LEFT + 1 If Block = 3 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3 If Block = 4 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3 If Block = 6 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3 If Block = 7 And TOP_X_R = BOTTOM_X_RIGHT - 1 And ROTATE_NUM = 1 Then x = BOTTOM_X_RIGHT - 3 ROTATE_NUM = tmp_ROTATE_NUM Call getRandBlock(x, y, Block) Call setTopPlace(x, y, Block) Else Call getRandBlock(x, y, Block) End If End Sub ' ブロックが回転できるか できるなら True Function checkRotateBlock(ByVal x As Integer, ByVal y As Integer, ByRef Block As Integer) checkRotateBlock = False Select Case Block Case 1 checkRotateBlock = checkRotateBlock1(x, y) Case 2 checkRotateBlock = checkRotateBlock2(x, y) Case 3 checkRotateBlock = checkRotateBlock3(x, y) Case 4 checkRotateBlock = checkRotateBlock4(x, y) Case 5 checkRotateBlock = checkRotateBlock5(x, y) Case 6 checkRotateBlock = checkRotateBlock6(x, y) Case 7 checkRotateBlock = checkRotateBlock7(x, y) End Select End Function ' 正方形 ブロックが回転できるか できるなら True Function checkRotateBlock1(ByVal x As Integer, ByVal y As Integer) As Boolean checkRotateBlock1 = True Const color As Integer = BLOCK1_COLOR If checkNoColor(color, x + 1, y) = False _ Or checkNoColor(x + 2, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock1 = False End If End Function ' 長方形 ブロックが回転できるか できるなら True Function checkRotateBlock2(ByVal x As Integer, ByVal y As Integer) checkRotateBlock2 = True Const color As Integer = BLOCK2_COLOR If ROTATE_NUM = 1 Then If checkNoColor(x + 2, y) = False _ Or checkNoColor(x + 2, y - 1) = False _ Or checkNoColor(x + 2, y - 2) = False _ Or checkNoColor(x + 2, y - 3) = False _ Then checkRotateBlock2 = False End If Else If checkNoColor(x, y - 2) = False _ Or checkNoColor(x + 1, y - 2) = False _ Or checkNoColor(x + 2, y - 2) = False _ Or checkNoColor(x + 3, y - 2) = False _ Then checkRotateBlock2 = False End If End If End Function ' L字 ブロックが回転できるか できるなら True Function checkRotateBlock3(ByVal x As Integer, ByVal y As Integer) checkRotateBlock3 = True Const color As Integer = BLOCK3_COLOR If ROTATE_NUM = 0 Then If checkNoColor(x, y) = False _ Or checkNoColor(x, y - 1) = False _ Or checkNoColor(x, y - 2) = False _ Or checkNoColor(x + 1, y - 2) = False _ Then checkRotateBlock3 = False End If ElseIf ROTATE_NUM = 1 Then If checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y - 1) = False _ Or checkNoColor(x + 2, y) = False _ Then checkRotateBlock3 = False End If ElseIf ROTATE_NUM = 2 Then If checkNoColor(x, y) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Then checkRotateBlock3 = False End If Else If checkNoColor(x, y) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 2, y) = False _ Or checkNoColor(x, y - 1) = False _ Then checkRotateBlock3 = False End If End If End Function ' 逆L字 ブロックが回転できるか できるなら True Function checkRotateBlock4(ByVal x As Integer, ByVal y As Integer) checkRotateBlock4 = True Const color As Integer = BLOCK4_COLOR If ROTATE_NUM = 0 Then If checkNoColor(x, y) = False _ Or checkNoColor(x, y - 1) = False _ Or checkNoColor(x, y - 2) = False _ Or checkNoColor(x + 1, y) = False _ Then checkRotateBlock4 = False End If ElseIf ROTATE_NUM = 1 Then If checkNoColor(x, y) = False _ Or checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock4 = False End If ElseIf ROTATE_NUM = 2 Then If checkNoColor(x, y - 2) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Then checkRotateBlock4 = False End If Else If checkNoColor(x, y) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 2, y) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock4 = False End If End If End Function ' 山 ブロックが回転できるか できるなら True Function checkRotateBlock5(ByVal x As Integer, ByVal y As Integer) checkRotateBlock5 = True Const color As Integer = BLOCK5_COLOR If ROTATE_NUM = 0 Then If checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock5 = False End If ElseIf ROTATE_NUM = 1 Then If checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y - 1) = False _ Or checkNoColor(x + 1, y) = False _ Then checkRotateBlock5 = False End If ElseIf ROTATE_NUM = 2 Then If checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Then checkRotateBlock5 = False End If Else If checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock5 = False End If End If End Function ' Z字 ブロックが回転できるか できるなら True Function checkRotateBlock6(ByVal x As Integer, ByVal y As Integer) checkRotateBlock6 = True Const color As Integer = BLOCK6_COLOR If ROTATE_NUM = 0 Then If checkNoColor(x, y) = False _ Or checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 1, y - 2) = False _ Then checkRotateBlock6 = False End If Else If checkNoColor(x, y - 1) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y) = False _ Then checkRotateBlock6 = False End If End If End Function ' 逆Z字 ブロックが回転できるか できるなら True Function checkRotateBlock7(ByVal x As Integer, ByVal y As Integer) checkRotateBlock7 = True Const color As Integer = BLOCK7_COLOR If ROTATE_NUM = 0 Then If checkNoColor(x, y - 1) = False _ Or checkNoColor(x, y - 2) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Then checkRotateBlock7 = False End If Else If checkNoColor(x, y) = False _ Or checkNoColor(x + 1, y) = False _ Or checkNoColor(x + 1, y - 1) = False _ Or checkNoColor(x + 2, y - 1) = False _ Then checkRotateBlock7 = False End If End If End Function |
ブロックが一行並べば消す
ブロックの移動が完了すれば次は、ブロックが一行そろっているか確認し、そろっている場合はその行を削除してスコアに加算します。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
' ブロックの1列ブロックが削除できるところか Sub checkRowBlock() Dim x, y, n: n = BOTTOM_Y Dim nocolor As Integer Dim flag Dim Score_num: Score_num = 0 Dim cellcolor1, cellcolor2 ' そろっている行をグレーにする For y = BOTTOM_Y - 1 To START_Y Step -1 nocolor = 0 For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 Step 1 If checkNoColor(x, y) = True Then nocolor = nocolor + 1 End If Next x If nocolor = BOTTOM_X_RIGHT - BOTTOM_X_LEFT - 1 Then Exit For ElseIf nocolor = 0 Then flag = 1 For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 Step 1 With Worksheets(TETRIS_SHEET).Cells(y, x) .Interior.color = RGB(192, 192, 192) .Borders.LineStyle = xlContinuous End With Next x End If Next y ' グレーの行を削除 If flag = 1 Then Application.ScreenUpdating = False For y = BOTTOM_Y - 1 To START_Y Step -1 cellcolor1 = Worksheets(TETRIS_SHEET).Cells(y, BOTTOM_X_LEFT + 1).Interior.color If cellcolor1 = RGB(192, 192, 192) Then Score_num = Score_num + 1 For n = y To START_Y Step -1 For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 With Worksheets(TETRIS_SHEET).Cells(n, x) .ClearFormats .Interior.color = Worksheets(TETRIS_SHEET).Cells(n - 1, x).Interior.color End With If checkNoColor(x, n - 1) = False Then With Worksheets(TETRIS_SHEET).Cells(n, x) .Borders.LineStyle = xlContinuous End With End If Next x Next n End If cellcolor1 = Worksheets(TETRIS_SHEET).Cells(y, BOTTOM_X_LEFT + 1).Interior.color If cellcolor1 = RGB(192, 192, 192) Then y = y + 1 End If Next y Application.ScreenUpdating = False End If If Score_num > 0 Then Score = Score + 100 + Score_num * 300 End If Worksheets(TETRIS_SHEET).Cells(SCORE_POSITION_Y, SCORE_POSITION_X).Value = Score End Sub |
テトリスの終了条件をつける
あとは終了条件だけですね。ある行を天井と決め、その行よりも一つ上の行を端から端までセルの書式を確認し、ブロックがあれば（セルに色がついてあれば）メッセージを表示させ終了させます。
ソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
' ゲーム終了 Private Sub checkgame() Dim x For x = BOTTOM_X_LEFT + 1 To BOTTOM_X_RIGHT - 1 If checkNoColor(x, START_Y - 1) = False Then MsgBox "Game Over!" & Chr(13) & "Score : " & Score End End If Next x End Sub |
最後に
いかがでしょうか？
長々と失礼しました。この記事49000文字近くまでいってました、、、まあ大半がソースコードですが。
これ思ったより作るのめんどくさかったですね。。けれどゲームをつくるのってやっぱり楽しいです。
皆様もよければぜひ参考に作ってみてください！
最後にこのテトリスが気になる人もしくは作成したテトリスを参考にしたい人がいれば、ぜひダウンロードしてみてください！
