上級162回のコード

2022年12月12日 19:33

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 Boolean

Sub 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 Sub

Sub 回転(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 Sub

Sub 移動(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 Sub

Sub 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 If

Option 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

上級162回のコード

いいなと思ったら応援しよう！