上級83回のコード

メイン

 #If  Win64 Then
   Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else 
   Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End  If
Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Public gameFG As Boolean
Public ws As Worksheet
Public Const baceX As Integer = 150
Public Const baceY As Integer = 10
Public Const baceW As Integer = 350
Public Const baceH As Integer = 380
Public Const ballW As Integer = 20
Public Const blockW As Integer = 50
Public Const blockH As Integer = 20
Public Const Rect As Integer = msoShapeRectangle
Public Const Oval As Integer = msoShapeOval
Private gamen As 部品
Private tama As 球
Private ita As 板
Private block(0 To 27) As 岩
Private blockList(0 To 3, 0 To 6) As Integer

Sub Init()
   
   Dim i As Integer
   Dim j As Integer
   Dim c As Integer
   
   
   Dim sha As Shape
   
   Set ws = Sheets("Sheet1")
   
   If ws.Shapes.Count > 1 Then
       For Each sha In ws.Shapes
           If sha.name <> "gameBtn" Then
           
               sha.Delete
           End If
       Next
   End If
   
   Set gamen = New 部品
   Set tama = New 球
 
   Set ita = New 板
   
   
   gamen.Create Rect, 0, 0, baceW, baceH
   gamen.setName "gamen"
   gamen.setStyle RGB(0, 0, 0), RGB(255, 255, 255)
   
   tama.部品_Create Oval, baceW / 2 - ballW / 2, baceH - (30 + ballW), ballW, ballW
   tama.部品_setName "tama"
   tama.部品_setStyle RGB(255, 255, 255), RGB(255, 255, 255)
   ita.部品_Create Rect, baceW / 2 - blockW / 2, baceH - 30, blockW, 10
   ita.部品_setName "ita"
   ita.部品_setStyle RGB(255, 255, 100), RGB(255, 255, 255)
   c = 0
   For j = 0 To 3
       For i = 0 To 6
           
           blockList(j, i) = 1
           Set block(c) = New 岩
           
           block(c).部品_Create Rect, i * blockW, j * 20, blockW, 20
           block(c).部品_setName "block" & c
           block(c).部品_setStyle RGB(100, 100, 100), RGB(255, 255, 255)
           
           c = c + 1
       Next i
   Next j
End Sub

Sub Game()
   Dim x As Integer
   
   Call Init
   x = 300
   
   Do While gameFG
       ita.Move (keyEvent())
       blockID = tama.Move(ita.x_, blockList)
       
       If blockID = -1 Then
       
           gameFG = False
           MsgBox "Game Over"
           
       ElseIf blockID <> 99 Then
           block(blockID).Delete
       End If
       Sleep 10
       DoEvents
       
   Loop
   
   
End Sub
Function keyEvent() As Integer
   Dim inputKey
   
   If GetAsyncKeyState(vbKeyLeft) Then
       inputKey = -1
       
   ElseIf GetAsyncKeyState(vbKeyRight) Then
       inputKey = 1
   End If
   
   keyEvent = inputKey
   
End Function

ボタン

Private Sub gameBtn_Click()
   If gameFG Then
       gameBtn.Caption = "START"
       gameFG = False
   Else
       gameBtn.Caption = "STOP"
       gameFG = True
       Call Game
   End If
End Sub

岩クラス

Private x_ As Integer
Private y_ As Integer
Private MY As Shape

Public Sub 部品_Create(katachi As Integer, x As Integer, y As Integer, w As Integer, h As Integer)
   x_ = x
   y_ = y
   ws.Shapes.AddShape katachi, baceX + x_, baceY + y_, w, h
   Set MY = ws.Shapes(ws.Shapes.Count)
   
End Sub
Public Sub 部品_setName(name As String)
   MY.name = name
End Sub
Public Sub 部品_setStyle(fillColor As Long, lineColor As Long)
   MY.Fill.ForeColor.RGB = fillColor
   MY.Line.ForeColor.RGB = lineColor
End Sub
Public Sub Delete()
   MY.Delete
End Sub

球クラス

Implements 部品
Private x_ As Integer
Private y_ As Integer
Private hx_ As Integer
Private hy_ As Integer
Private MY As Shape
Private Sub Class_Initialize()
   hx_ = 1
   hy_ = -1
   
End Sub
Public Sub 部品_Create(katachi As Integer, x As Integer, y As Integer, w As Integer, h As Integer)
   x_ = x
   y_ = y
   ws.Shapes.AddShape katachi, baceX + x_, baceY + y_, w, h
   Set MY = ws.Shapes(ws.Shapes.Count)
   
End Sub
Public Sub 部品_setName(name As String)
   MY.name = name
End Sub
Public Sub 部品_setStyle(fillColor As Long, lineColor As Long)
   MY.Fill.ForeColor.RGB = fillColor
   MY.Line.ForeColor.RGB = lineColor
End Sub

Public Function Move(itaX As Integer, blockList() As Integer) As Integer

   Dim blockID As Integer
   Dim r As Integer
   Dim c As Integer
   
   blockID = 99
   


   
   '上下
   If (y_ + 2) Mod blockH <= 4 Then
       If (y_ + (1 + hy_) * ballW / 2) / blockH <= 4 Then '4.3が正解
           r = (y_ + (1 + hy_) * ballW / 2) / blockH + (hy_ - 1) / 2
           c = Int((x_ + ballW / 2) / blockW)
           If r >= 0 And r < 4 Then
               If 1 = blockList(r, c) Then
                   blockList(r, c) = 0
                   hy_ = hy_ * -1
                   blockID = r * 7 + c
               End If
           End If
       End If

   End If

   '左右
   If y_ / blockH < 4 Then
       If ((x_ + (1 + hx_) * ballW / 2) + 2) Mod blockW <= 2 Then
           r = Int(y_ / blockH)
           c = (x_ + (1 + hx_) * ballW / 2) / blockW + (hx_ - 1) / 2

           If c >= 0 And c < 7 Then
               If 1 = blockList(r, c) Then
                   blockList(r, c) = 0
                   hx_ = hx_ * -1
                   blockID = r * 7 + c
               End If
           End If
       End If
   End If
   
   If (y_ + ballW) >= (baceH - 30) And (y_ + ballW) < (baceH - 20) Then

       If (x_ + ballW / 2) >= itaX And (x_ + ballW / 2) <= (itaX + blockW) Then
           hy_ = -1
       End If
   End If

   If x_ <= 0 Or x_ >= (baceW - ballW) Then
       hx_ = hx_ * -1
   ElseIf y_ <= 0 Then
       hy_ = hy_ * -1
   ElseIf y_ >= (baceH - ballW) Then
       blockID = -1
   End If

   x_ = x_ + 3 * hx_
   y_ = y_ + 3 * hy_
           

   MY.Left = baceX + x_
   MY.Top = baceY + y_
   
   Move = blockID
End Function

板クラス

Implements 部品
Public x_ As Integer
Private y_ As Integer
Private MY As Shape
Public Sub 部品_Create(katachi As Integer, x As Integer, y As Integer, w As Integer, h As Integer)
   x_ = x
   y_ = y
   ws.Shapes.AddShape katachi, baceX + x_, baceY + y_, w, h
   Set MY = ws.Shapes(ws.Shapes.Count)
   
End Sub
Public Sub 部品_setName(name As String)
   MY.name = name
End Sub
Public Sub 部品_setStyle(fillColor As Long, lineColor As Long)
   MY.Fill.ForeColor.RGB = fillColor
   MY.Line.ForeColor.RGB = lineColor
End Sub
Public Sub Move(KeyVal As Integer)
   If 0 <= (x_ + KeyVal * 5) Then
       If (baceW - 50) >= (x_ + KeyVal * 5) Then
           x_ = x_ + KeyVal * 5
       End If
   End If
   MY.Left = baceX + x_
End Sub

部品クラス

Private x_ As Integer
Private y_ As Integer
Private MY As Shape

Public Sub Create(katachi As Integer, x As Integer, y As Integer, w As Integer, h As Integer)
   x_ = x
   y_ = y
   ws.Shapes.AddShape katachi, baceX + x_, baceY + y_, w, h
   Set MY = ws.Shapes(ws.Shapes.Count)
   
End Sub
Public Sub setName(name As String)
   MY.name = name
End Sub
Public Sub setStyle(fillColor As Long, lineColor As Long)
   MY.Fill.ForeColor.RGB = fillColor
   MY.Line.ForeColor.RGB = lineColor
End Sub