上級162回のコード
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End If
Private Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Dim posi As Integer
Dim p1 As Range
Dim p2 As Range
Dim list() As Long
Dim count As Long
Dim bCount As Long
Dim bKey As Long
Const T As Integer = 1
Const R As Integer = 2
Const B As Integer = 3
Const L As Integer = 4
Dim p1color As Long
Dim p2color As Long
'追加
Public fg As BooleanSub game()
Dim colors(4) As Long
colors(0) = RGB(255, 0, 0)
colors(1) = RGB(0, 0, 255)
colors(2) = RGB(255, 220, 0)
colors(3) = RGB(0, 200, 0)
colors(4) = RGB(230, 0, 240)
Range("B2:H15").Clear
Randomize
p1color = colors(Int(5 * Rnd))
p2color = colors(Int(5 * Rnd))
Range("K4").Interior.color = colors(Int(5 * Rnd))
Range("K5").Interior.color = colors(Int(5 * Rnd))
Call test7
Do While fg
p1color = Range("K5").Interior.color
p2color = Range("K4").Interior.color
Range("K4").Interior.color = colors(Int(5 * Rnd))
Range("K5").Interior.color = colors(Int(5 * Rnd))
Call test7
Loop
End Sub
Sub test7()
Dim fg1 As Boolean
Dim fg2 As Boolean
Dim x As Integer
Dim y As Integer
Dim c As Collection
Dim color As Long
Dim count As Long
Dim rn As Range
' Dim colors(4) As Long
' colors(0) = RGB(255, 0, 0)
' colors(1) = RGB(0, 0, 255)
' colors(2) = RGB(255, 220, 0)
' colors(3) = RGB(0, 200, 0)
' colors(4) = RGB(230, 0, 240)
y = 0
posi = T
Set p1 = Range("E2")
Set p2 = Range("E1")
'Randomize
'追加
count = 1
p1.Interior.color = p1color
p2.Interior.color = p2color
fg1 = True
fg2 = True
ReDim list(1 To 15, 1 To 7)
Do While fg1 And fg2 And fg '追加
If count Mod 8 = 0 Then
Select Case posi
Case T
fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
y = -1
x = 0
Case R
fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
y = 0
x = 1
Case B
fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
y = 1
x = 0
Case L
fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
y = 0
x = -1
End Select
'描画
If fg1 And fg2 Then
'If p1.Row > 1 Then
p1.Interior.ColorIndex = xlNone
'End If
'If p2.Row > 1 Then
p2.Interior.ColorIndex = xlNone
'End If
Set p1 = p1.Offset(1, 0)
Set p2 = p1.Offset(y, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
End If
End If
Call keyInput
Sleep 100
count = count + 1
DoEvents
Loop
'追加
If fg Then
y = 1
'浮いてる方を落とす
Do While fg1 Or fg2
fg1 = p1.Offset(y, 0).Interior.ColorIndex = xlNone
fg2 = p2.Offset(y, 0).Interior.ColorIndex = xlNone
If fg1 Then
p1.Offset(y, 0).Interior.color = p1color
p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone
ElseIf fg2 Then
p2.Offset(y, 0).Interior.color = p2color
p2.Offset(y - 1, 0).Interior.ColorIndex = xlNone
End If
Sleep 250
DoEvents
y = y + 1
Loop
fg1 = True
Do While fg1
fg1 = False
'4個以上つながった所を消す
ReDim list(1 To 15, 1 To 7)
For y = 1 To 15
For x = 1 To 7
list(y, x) = 1
If Range("a1").Offset(y - 1, x).Interior.ColorIndex <> xlNone Then
color = Range("a1").Offset(y - 1, x).Interior.color
Set c = New Collection
c.Add Range("a1").Offset(y - 1, x)
Check c, y, x, color
If c.count >= 4 Then
fg1 = True
For Each rn In c
rn.Interior.ColorIndex = xlNone
Next
End If
End If
Next x
Next y
'新たaに浮いたところを落とす
fg2 = True
Do While fg2
fg2 = False
For y = 14 To 1 Step -1
For x = 1 To 7
If Range("a1").Offset(y - 1, x).Interior.ColorIndex <> xlNone Then
If Range("a1").Offset(y, x).Interior.ColorIndex = xlNone Then
color = Range("a1").Offset(y - 1, x).Interior.color
Range("a1").Offset(y, x).Interior.color = color
Range("a1").Offset(y - 1, x).Interior.ColorIndex = xlNone
fg2 = True
End If
End If
Next x
Next y
DoEvents
Sleep 250
Loop
Loop
'追加
End If
End SubSub 回転(bKey As Long)
Select Case posi
Case T
'右が空白
If p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p2 = p1.Offset(0, 1)
p2.Interior.color = p2color
posi = R
bKey = vbKeyA
'左は空白
ElseIf p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, -1)
Set p2 = p1.Offset(0, 1)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = R
bKey = vbKeyA
'両方空いていないが前回入力が回転の場合
ElseIf bKey = vbKeyA Then
If p1.Offset(1, 0).Interior.ColorIndex = xlNone Then
Set p1 = p1.Offset(-1, 0)
Set p2 = p1.Offset(1, 0)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = B
Else
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(-1, 0)
Set p2 = p1.Offset(1, 0)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = B
End If
bKey = 0
Else
bKey = vbKeyA
End If
Case R
If p1.Offset(1, 0).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p2 = p1.Offset(1, 0)
p2.Interior.color = p2color
posi = B
Else
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(-1, 0)
Set p2 = p1.Offset(1, 0)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = B
End If
bKey = vbKeyA
Case B
'左が空白
If p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p2 = p1.Offset(0, -1)
p2.Interior.color = p2color
posi = L
bKey = vbKeyA
'右は空白
ElseIf p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, 1)
Set p2 = p1.Offset(0, -1)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = R
bKey = vbKeyA
'両方空いていないが前回入力が回転の場合
ElseIf bKey = vbKeyA Then
Set p1 = p1.Offset(1, 0)
Set p2 = p1.Offset(-1, 0)
p1.Interior.color = p1color
p2.Interior.color = p2color
posi = T
bKey = 0
Else
bKey = vbKeyA
End If
Case L
p2.Interior.ColorIndex = xlNone
Set p2 = p1.Offset(-1, 0)
p2.Interior.color = p2color
posi = T
bKey = vbKeyA
End Select
End SubSub 移動(x As Integer)
Select Case posi
Case T
If p1.Offset(0, x).Interior.ColorIndex = xlNone Then
p1.Interior.ColorIndex = xlNone
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
End If
Case R
If x = 1 And p1.Offset(0, 2).Interior.ColorIndex = xlNone Then
p1.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
ElseIf x = -1 And p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
End If
Case B
If p2.Offset(0, x).Interior.ColorIndex = xlNone Then
p1.Interior.ColorIndex = xlNone
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
End If
Case L
If x = 1 And p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
p2.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
ElseIf x = -1 And p1.Offset(0, -2).Interior.ColorIndex = xlNone Then
p1.Interior.ColorIndex = xlNone
Set p1 = p1.Offset(0, x)
Set p2 = p2.Offset(0, x)
p1.Interior.color = p1color
p2.Interior.color = p2color
End If
End Select
End Sub
Sub keyInput()
If bKey <> vbKeyA Then
bKey = 0
ElseIf count - bCount > 6 Then
bKey = 0
End If
If GetAsyncKeyState(vbKeyA) Then
bCount = count
Call 回転(bKey)
ElseIf GetAsyncKeyState(vbKeyRight) Then
Call 移動(1)
bKey = vbKeyRight
ElseIf GetAsyncKeyState(vbKeyLeft) Then
Call 移動(-1)
bKey = vbKeyLeft
End If
End SubSub Check(c As Collection, y As Integer, x As Integer, color)
If y < 15 Then
If list(y + 1, x) = 0 Then
If Range("a1").Offset(y, x).Interior.color = color Then
list(y + 1, x) = 1
c.Add Range("a1").Offset(y, x)
Check c, y + 1, x, color
End If
End If
End If
If x > 1 Then
If list(y, x - 1) = 0 Then
If Range("a1").Offset(y - 1, x - 1).Interior.color = color Then
list(y, x - 1) = 1
c.Add Range("a1").Offset(y - 1, x - 1)
Check c, y, x - 1, color
End If
End If
End IfOption Explicit
Private Sub CommandButton1_Click()
If Not fg Then
CommandButton1.Caption = "終了"
DoEvents
fg = True
Call game
Else
CommandButton1.Caption = "開始"
DoEvents
fg = False
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If fg Then
Range("a1").Select
Range("a1") = ""
End If
End Sub
この記事が気に入ったらサポートをしてみませんか？