Visual Basicでブロック崩しを作ろう

全てのブロックを消したら、ゲームを続行できるようにします。

現状では「クリアしました！」とメッセージを表示しているだけで、ゲームを続行できませんので、これを改善します。

メッセージを「クリアしました！続けますか？」に変更してYes/Noを問い合わせるようにします。
Noだったらアプリを終了します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Dim r As Long
            Timer1.Enabled = False
            r = MsgBox("クリアしました！続けますか？", vbYesNo)
            If r = vbNo Then
                Me.Close()
                Exit Sub
            End If
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
            If score > highscore Then
                MsgBox("ハイスコアを更新しました！！！！！！！")
                highscore = score
                Save()
            End If
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
        ScoreLabel.Text = "スコア: " & score
    End Sub

Yesなら画面を初期状態に戻してゲームを再開します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Dim r As Long
            Timer1.Enabled = False
            r = MsgBox("クリアしました！続けますか？", vbYesNo)
            If r = vbNo Then
                Me.Close()
                Exit Sub
            End If
            PrepareGame()
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
            If score > highscore Then
                MsgBox("ハイスコアを更新しました！！！！！！！")
                highscore = score
                Save()
            End If
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
        ScoreLabel.Text = "スコア: " & score
    End Sub

    Public Sub PrepareGame()
        '全ブロックを再表示する
        ShowAllBricks()
        'ボールの位置を適当な場所に移動する
        x = 230
        y = 180
        'ボールの方向を落ちる方にする
        dy = Math.Abs(dy)
        Timer1.Enabled = True
    End Sub

    Public Sub ShowAllBricks()
        Dim i, j As Integer
        For i = 0 To 9
            For j = 0 To 5
                Select Case j
                    Case 0, 1
                        brick(i, j).BackColor = Color.Red
                    Case 2, 3
                        brick(i, j).BackColor = Color.Yellow
                    Case 4, 5
                        brick(i, j).BackColor = Color.Green
                End Select
                brick(i, j).Visible = True
            Next
        Next
    End Sub

テスト用に、画面の左下にボタンを追加し、Textプロパティを「スコア保存」に設定します。Nameプロパティを「SaveScore」に変更しておきます。

プログラムの先頭にハイスコアを保存するためのファイル名を表すSCORE_FILE定数とhighscore変数を追加します。

Public Class Form1
    Const SCORE_FILE = "score.txt"
    :
    Dim score, highscore As Integer
    :

ボタンをダブルクリックしてイベントプロシージャを作成します。

    Private Sub SaveScore_Click(sender As Object, e As EventArgs) Handles SaveScore.Click
        Save()
    End Sub

    Public Sub Save()
        'スコアをファイルに保存する
        My.Computer.FileSystem.WriteAllText(SCORE_FILE, highscore, False)
    End Sub

アプリを起動して「スコア保存」ボタンをクリックすると、プロジェクトのフォルダ内に「score.txt」ファイルが生成されています。

アプリを起動したときに「score.txt」を読み込んで、ハイスコアを表示するように変更してみます。

フォームのスコアの左側にハイスコアを表示するためのLabelを追加します。

Form_Load内で「score.txt」ファイルを読み込んで、ハイスコアを表示します。

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
    :
        'ハイスコアをファイルから参照する
        If IO.File.Exists(SCORE_FILE) Then
            Dim s As String
            s = My.Computer.FileSystem.ReadAllText(SCORE_FILE)
            highscore = Val(s)
        End If
        HighScoreLabel.Text = "ハイスコア: " & highscore
    End Sub

ハイスコアを保存するところと表示するところはできました。

次は、ゲームを開始してゲームオーバーになった時点で、ハイスコアよりも高いスコアだった時に、そのスコアをファイルに書き込むようにします。

タイマーイベント内でゲームオーバーのメッセージを表示している個所に追加します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Timer1.Enabled = False
            MsgBox("クリアしました！")
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
        ScoreLabel.Text = "スコア: " & score
    End Sub

ゲームオーバーになったときにスコアがこれまでのハイスコアよりも大きかったら、ハイスコアを更新したことをメッセージを表示して、ファイルを更新します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Timer1.Enabled = False
            MsgBox("クリアしました！")
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
            If score > highscore Then
                MsgBox("ハイスコアを更新しました！！！！！！！")
                highscore = score
                Save()
            End If
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
        ScoreLabel.Text = "スコア: " & score
    End Sub

現在はボールがブロックに一度だけ当たればブロックは消えますが、複数回当たらないと消えないブロックを作ってみましょう。

ブロックの上2段を赤、中2段を黄色、下の2段を緑にします。

    Public Sub MakeBricks()
        Dim i, j As Integer
        Dim bw, bh As Integer
        bw = 40
        bh = 10
        brick = New Label(9, 5) {}
        For i = 0 To 9
            For j = 0 To 5
                Dim c As Color
                Select Case j
                    Case 0, 1
                        c = Color.Red
                    Case 2, 3
                        c = Color.Yellow
                    Case 4, 5
                        c = Color.Green
                End Select
                brick(i, j) = New Label()
                brick(i, j).BackColor = c
                brick(i, j).Left = i * bw
                brick(i, j).Top = j * bh + 50
                brick(i, j).Width = bw
                brick(i, j).Height = bh
                brick(i, j).BorderStyle = BorderStyle.Fixed3D
                Me.Controls.Add(brick(i, j))
            Next
        Next
    End Sub

赤いブロックに当たるとブロックが黄色に変化し、黄色いブロックに当たるとブロックが緑に変化し、緑のブロックにあたるとブロックが消えるようにします。

これにより、赤いブロックは3回、黄色いブロックは2回ボールを当てないと消えないということになります。
いまは無条件にブロックを消していますが、この部分を修正します。

    Public Sub HitBricks()
        Dim i, j As Integer
        Dim r, br As Rectangle
        Dim b As Label

        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        For i = 0 To 9
            For j = 0 To 5
                b = brick(i, j)
                r = New Rectangle(b.Left, b.Top, b.Width, b.Height)
                If b.Visible = True And r.IntersectsWith(br) Then
                    Dim overlap As Rectangle
                    overlap = Rectangle.Intersect(r, br)
                    If overlap.Width > overlap.Height Then
                        dy = -dy
                    Else
                        dx = -dx
                    End If
                    b.Visible = False
                    score += 1
                    Exit Sub
                End If
            Next
        Next
    End Sub

ブロックの色が緑ならブロックを消し、黄色なら緑に色を変え、赤なら黄色に色を変えます。

                    If b.BackColor = Color.Green Then
                        b.Visible = False
                    ElseIf b.BackColor = Color.Yellow Then
                        b.BackColor = Color.Green
                    ElseIf b.BackColor = Color.Red Then
                        b.BackColor = Color.Yellow
                    End If

現状では、ボールがブロックの側面に当たっても、ボールは下向きに跳ね返ります。

しかしこの動きは不自然です。

ボールがブロックの側面に当たったときは、両側の壁に当たった時と同じようにx軸方向に跳ね返り、縦方向の動きは変わらないほうが自然です。

この動きを作ってみましょう。

ボールがブロックの側面に当たったかどうかは、ボールがブロックと当たった瞬間の重なり部分の形状で判断できます。

ボールがブロックの上の面または下の面に当たると、重なり部分は横長の四角形になります。これに対して、ボールがブロックの側面に当たると、重なり部分は縦長の四角形になります。

重なり部分の四角形は、Rectangleが持っているIntersects関数で取得できます。

重なり部分の四角形の幅と高さを比較して、幅が大きければ上の面または下の面、高さが大きければ側面に当たったと判断できます。

    Public Sub HitBlock()
        Dim i, j As Integer
        Dim r, br As Rectangle
        Dim b As Label

        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        For i = 0 To 9
            For j = 0 To 5
                b = block(i, j)
                r = New Rectangle(b.Left, b.Top, b.Width, b.Height)
                If b.Visible = True And r.IntersectsWith(br) Then
                    Dim overlap As Rectangle
                    overlap = Rectangle.Intersect(r, br)
                    If overlap.Width > overlap.Height Then
                        dy = -dy
                    Else
                        dx = -dx
                    End If
                    b.Visible = False
                    score += 1
                    Exit Sub
                End If
            Next
        Next
    End Sub

ブロック崩しでは、ボールのx軸方向の向きと、ラケットで打ち返した時のラケット上でのボールの位置によって、打ち返す方向が変わります。

これを実装してみましょう。

画面右側に向かっているボールを、ラケットの左半分で打ち返すと、ボールは画面左側に向かうように方向を変えます。同様に、画面左側に向かっているボールをラケットの右半分で打ち返すと、、ボールは画面右側に向かうように方向を変えます。

ボールのx軸方向の進行方向と、ボールのx座標が、ラケットの中央よりも右か左か、によって動きが変わります。

条件がちょっと複雑なので、ChangeDxファンクションプロシージャを作成して条件分岐するようにしましょう。
x軸方向の向きが変わるときはTrue、そうでないときはFalseを返します。

    Public Function ChangeDx(ByVal rr As Rectangle) As Boolean
        Dim center As Integer
        center = rr.Left + rr.Width / 2
        If dx > 0 And x < center Then '左から来たボールがラケットの左半分に当たった？
            Return True
        End If
        If dx < 0 And x > center Then '右から来たボールがラケットの右半分に当たった？
            Return True
        End If
        Return False
    End Function

HitRacket内でChangeDxを呼び出し、Trueならばdxの符号を反転させます。

    Public Sub HitRacket()
        Dim br, rr As Rectangle
        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        rr = New Rectangle(Racket.Left, Racket.Top, Racket.Width, Racket.Height)
        If rr.IntersectsWith(br) And dy > 0 Then
            dy = -dy
            'ボールがラケットに当たった位置によってはx方向も変える
            If ChangeDx(rr) Then
                dx = -dx
            End If
        End If
    End Sub

消したブロックの数をカウントして、その値をスコアとして表示するようにしましょう。

スコアを表示するためのLabelを画面の右上に配置します。そして、NameプロパティをScoreLabelとしておきます。

スコアをカウントするために、フォームに score 変数を追加します。

Public Class Form1
    Dim x, y, dx, dy As Integer
    Dim score As Integer

     :

そして、ブロックを消すごとにscoreをプラスし、最新のスコアをScoreLabelに表示します。

    Public Sub HitBricks()
        Dim i, j As Integer
        Dim r, br As Rectangle
        Dim b As Label

        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        For i = 0 To 9
            For j = 0 To 5
                b = brick(i, j)
                r = New Rectangle(b.Left, b.Top, b.Width, b.Height)
                If b.Visible = True And r.IntersectsWith(br) Then
                    dy = -dy
                    b.Visible = False
                    score += 1
                    Exit Sub
                End If
            Next
        Next
    End Sub

タイマーイベント内の最後で、スコアの表示を更新します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Timer1.Enabled = False
            MsgBox("クリアしました！")
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
        ScoreLabel.Text = "スコア: " & score
    End Sub

すべてのブロックを消せたときはクリア。また、ラケットでボールを打ち返すのに失敗したらゲームオーバーにします。

クリアした時、ゲームオーバーになったときは、それぞれメッセージを表示してタイマーイベントを無効化しましょう。

クリアできたかどうかの判断は、表示中のブロックの数が0になったことでわかります。

表示中のブロックの数を数える CountBricks() というファンクションプロシージャを作りましょう。

    Public Function CountBricks()
        Dim i, j, sum As Integer
        Dim b As Label
        sum = 0
        For i = 0 To 9
            For j = 0 To 5
                b = brick(i, j)
                If b.Visible Then
                    sum += 1
                End If
            Next
        Next
        Return sum
    End Function

タイマーイベント内で残りのブロックの数を見て、0になってたらクリアにします。
また、ボールがラケットよりも下に行ったらゲームオーバーにします。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()
        If CountBricks() = 0 Then
            Timer1.Enabled = False
            MsgBox("クリアしました！")
        End If
        If y > Racket.Top + Racket.Height Then
            Timer1.Enabled = False
            MsgBox("ゲームオーバー")
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
    End Sub

タイマーイベント内に、ボールとブロックの当たり判定を追加します。

しかし、ブロックは複数あってループで当たり判定を行う必要があります。

タイマーイベント内の処理が長くなるとコードが読みにくくなるので、HitBricksというサブプロシージャを作って、その中でブロックとボールの当たり判定を行うようにしましょう。

ついでに、ボールと壁の当たり判定は HitWall、ラケットとボールの当たり判定はHitRacketというサブプロシージャに分割します。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        HitWall()
        HitRacket()
        HitBricks()

        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y
    End Sub

    Public Sub HitWall()
        If x + dx <= 0 Or x + Ball.Width + dx > ClientSize.Width Then
            dx = -dx
        End If
        If y + dy <= 0 Or y + Ball.Height + dy > ClientSize.Height Then
            dy = -dy
        End If
    End Sub

    Public Sub HitRacket()
        Dim br, rr As Rectangle
        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        rr = New Rectangle(Racket.Left, Racket.Top, Racket.Width, Racket.Height)
        If rr.IntersectsWith(br) And dy > 0 Then
            dy = -dy
        End If
    End Sub

    Public Sub HitBricks()
        Dim i, j As Integer
        Dim r, br As Rectangle
        Dim b As Label

        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        For i = 0 To 9
            For j = 0 To 5
                b = brick(i, j)
                r = New Rectangle(b.Left, b.Top, b.Width, b.Height)
                If b.Visible = True And r.IntersectsWith(br) Then
                    dy = -dy
                    b.Visible = False
                    Exit Sub
                End If
            Next
        Next
    End Sub

ボールがブロックに当たると、ブロックが消えるようになりました。

ゲーム画面内にラケットとボールを配置して、ボールが壁で跳ね返ったり、ラケットでボールを打ち返せるようになったので、次は画面上にブロックを配置します。

ブロックを配置するMakeBricksサブプロシージャを作成し、画面を初期化する Form_Load内でこのサブプロシージャを呼び出すようにしてみます。

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        dx = 2
        dy = 2
        x = Ball.Left
        y = Ball.Top
        Timer1.Enabled = True
        Timer1.Interval = 5

        'ブロックを配置する
        MakeBricks()
    End Sub

    Dim brick As Label(,)

    Public Sub MakeBricks()
        Dim i, j As Integer
        Dim bw, bh As Integer
        bw = 40
        bh = 10
        brick = New Label(9, 5) {}
        For i = 0 To 9
            For j = 0 To 5
                brick(i, j) = New Label()
                brick(i, j).BackColor = Color.Red
                brick(i, j).Left = i * bw
                brick(i, j).Top = j * bh + 50
                brick(i, j).Width = bw
                brick(i, j).Height = bh
                brick(i, j).BorderStyle = BorderStyle.Fixed3D
                Me.Controls.Add(brick(i, j))
            Next
        Next
    End Sub

ブロックを配置することができました。

が、ボールはブロックがあってもすり抜けてしまいます。

次は、ブロックとボールの当たり判定です。

画面上でボールが動くようになったので、次はラケットを用意してボールを打ち返すようにしてみましょう。

まずはラケットをフォーム上に配置します。これもLabelで十分でしょう。
NameプロパティをRacketにします。
AutoSizeプロパティをFalseにすると、ラケットのラベルのサイズを自由に変更できます。
BackColorもお好みの色に設定します。

ラケットの準備ができたので、ラケットをマウスで動かせるようにします。

フォーム(Form1)のプロパティでイベントを選択してMouseMoveをダブルクリックします。
すると、MouseMoveイベントプロシージャが作られます。
マウスの位置に、ラケットの座標を合わせるようにします。

    Private Sub Form1_MouseMove(sender As Object, e As MouseEventArgs) Handles MyBase.MouseMove
        Racket.Left = e.X
    End Sub

マウスカーソルの動きに、ラケットが追従するようになります。

次はラケットとボールの当たり判定を追加します。
タイマーイベント内に追加しましょう。

ラケットとボールの当たり判定は、二つのコントロール(Label)に重なり部分があるかどうかを調べます。RectangleクラスにIntersectsWithという便利な関数がありますので、それを利用します。
ラケットの範囲を表すRectangleとボールの範囲を表すRectangleを用意して、重なりがあるかどうかを調べます。

ボールの範囲を表すRectangleの変数を「br」、ラケットの範囲を表すRectangleの変数を「rr」としています。

あと、ラケットの当たり判定をするのは、dy > 0 の場合だけにします。ボールがラケットの下の方に当たって上向きに動いたときは、直後にも当たり判定されてしまう可能性があるのですが、これを避けるために、ボールが上方向に動くときは判定しないようにします。

    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
        If x + dx <= 0 Or x + Ball.Width + dx > ClientSize.Width Then
            dx = -dx
        End If
        If y + dy <= 0 Or y + Ball.Height + dy > ClientSize.Height Then
            dy = -dy
        End If
        x = x + dx
        y = y + dy
        Ball.Left = x
        Ball.Top = y

        Dim br, rr As Rectangle
        br = New Rectangle(x, y, Ball.Width, Ball.Height)
        rr = New Rectangle(Racket.Left, Racket.Top, Racket.Width, Racket.Height)
        If rr.IntersectsWith(br) And dy > 0 Then
            dy = -dy
        End If
    End Sub