Re5：50歳から始めるラズベリーパイ-14
Re5：50歳から始めるラズベリーパイ
簡単なゲームで学ぶVBAプログラミング入門
amazon kindle版を出版しました。
3.7 ブロック崩しゲームの作成-4
プログラムです。
'************************************************
Option VBAsupport 1
Dim bv As Double '速度
Dim bx As Double 'ボール位置
Dim by As Double
Dim th As Double 'ボールの角度
Dim pi As Double
Dim rx As Integer
Dim ct As Integer '残りブロック数
Dim block(7, 20) As Integer
Range("B22").Select
End Sub
Sub button1_Click()
Dim n As Integer
Dim hn as Integer
n = 0
hn=1
Call syoki
LP1:
n = n + 1
Call move_racket
Call move_ball
'DoEvents
If (Int(by) = 7 and th>0 and hn=0) Then
Call brock_hyoji
hn=1
End If
if(th<0 and int(by)=8)then
hn=0
endif
Call nokori
'Range("U5").value=th
If (ct = 0) Then
Range("U5").value= ("全消し！！")
GoTo LP_END
End If
If (by >= 21 Or n >= 300000) Then
Range("U5").value= ("GAMEOVER")
GoTo LP_END
End If
'wait 50 'ここを変えると速度変化
'
GoTo LP1
LP_END:
End Sub
'************************************************
'初期設定
Sub syoki()
Dim i As Integer
Dim ii As Integer
Dim wi As Integer
Range("U5").value= ""
Range("A1:T50").Clear 'A1からT50の範囲をクリア"
'Range("A1:J10").Borders.LineStyle = xlContinuous
Range("A:T").ColumnWidth = 1.5 '幅を設定する
wi = Columns("A").Width '幅を取得する
Range("1:50").RowHeight = wi
Range("A1:J21").Interior.Color = RGB(0, 0, 0)
'Range("K1:T21").Interior.Color = RGB(255,255, 255)
'Range("A2:T2").Interior.Color = RGB(255, 0, 0)
'Range("A3:T3").Interior.Color = RGB(255, 255, 0)
'Range("A4:T4").Interior.Color = RGB(0, 255, 0)
'Range("A5:T5").Interior.Color = RGB(0, 255, 255)
Range("A6:j6").Interior.Color = RGB(0, 0, 255)
pi = 3.14159
th = -45
bv = 0.5
rx = 3
bx = 5
by = 16
For i = 0 To 9
For ii = 0 To 4
block(ii, i) = 0
Next ii
Next i
'ブロックの配置
For i = 0 To 9
For ii = 4 To 4
block(ii, i) = 1
Next ii
Next i
Call brock_hyoji
End Sub
'************************************************
'ボールの移動
Sub move_ball()
Dim i As Integer
Dim ii As Integer
Cells(Int(by), Int(bx)).Interior.Color = RGB(0, 0, 0)
bx = bx + bv * Cos(th / 180 * pi)
by = by + bv * Sin(th / 180 * pi)
'反射する
'左右反射は180-θ
If (bx < 1 Or bx > 10) Then
th = 180 - th
End If
'上下反射は-θ
If (by < 1) Then '一番上
th = -th
End If
'ラケットがあったら反射
If (by > 19 And rx <= Int(bx) And rx + 3 >= Int(bx)) Then
th = -th
End If
'進行方向にブロックがあったら反射＆ブロックを消す
i = int(bx + bv * Cos(th / 180 * pi))
ii = int(by + bv * Sin(th / 180 * pi))-2
'Cells(25, 21).Value = i
'Cells(25, 22).Value = ii
If (ii <= 6 And ii >= 0) Then
If (block(ii, i) = 1) Then
block(ii, i) = 0
'Call brock_hyoji
'Call nokori
th = -th
End If
End If
If (bx <= 1) Then
bx = 1
End If
If (by <= 1) Then
by = 1
End If
If (bx >= 10) Then
bx = 10
End If
If (by >= 21) Then
by = 21
End If
if(th>180)then
th=th-360
endif
if(th<-180) then
th=th+360
endif
Cells(Int(by), Int(bx)).Interior.Color = RGB(255, 255, 255)
End Sub
'************************************************
'残りブロック数計算
Sub nokori()
Dim i As Integer
Dim ii As Integer
ct = 0
For i = 0 To 9
For ii = 0 To 4
If (block(ii, i) = 1) Then
ct = ct + 1
End If
Next ii
Next i
Cells(3, 21).Value = ct
End Sub
'************************************************
'ラケットの移動
Sub move_racket()
Dim kx as Integer
kx = ActiveCell.Column
If (kx<2) Then
rx = rx - 1
If (rx <= 1) Then
rx = 1
End If
'Cells(1, 21).Value = rx
Range("A20:j20").Interior.Color = RGB(0, 0, 0)
Cells(20, rx).Interior.Color = RGB(255, 255, 255)
Cells(20, rx + 1).Interior.Color = RGB(255, 255, 255)
Cells(20, rx + 2).Interior.Color = RGB(255, 255, 255)
Range("B22").Select
End If
If (kx>2) Then
rx = rx + 1
If (rx >= 8) Then
rx = 8
End If
'Cells(1, 21).Value = rx
Range("A20:j20").Interior.Color = RGB(0, 0, 0)
Cells(20, rx).Interior.Color = RGB(255, 255, 255)
Cells(20, rx + 1).Interior.Color = RGB(255, 255, 255)
Cells(20, rx + 2).Interior.Color = RGB(255, 255, 255)
Range("B22").Select
End If
'矢印キーを使うので、カーソルがあさっての方に行かないように
End Sub
'************************************************
'ブロックの表示
Sub brock_hyoji()
Dim i As Integer
Dim ii As Integer
For ii = 0 To 5
For i = 0 To 9
Cells(ii + 2, i + 1).Interior.Color = RGB(0, 0, 0)
If (ii = 0 And block(ii, i) = 1) Then
Cells(ii + 2, i + 1).Interior.Color = RGB(255, 0, 0)
End If
If (ii = 1 And block(ii, i) = 1) Then
Cells(ii + 2, i + 1).Interior.Color = RGB(255, 255, 0)
End If
If (ii = 2 And block(ii, i) = 1) Then
Cells(ii + 2, i + 1).Interior.Color = RGB(0, 255, 0)
End If
If (ii = 3 And block(ii, i) = 1) Then
Cells(ii + 2, i + 1).Interior.Color = RGB(0, 255, 255)
End If
If (ii = 4 And block(ii, i) = 1) Then
Cells(ii + 2, i + 1).Interior.Color = RGB(0, 0, 255)
End If
Next i
Next ii
'For ii = 0 To 4
' For i = 0 To 19
' Cells(ii + 30, i + 1).Value = block(ii, i)
' Next i
'Next ii
End Sub
