上級161回のコード

2022年12月9日 16:54

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

Sub test6()
    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
    
    

    
    y = 0
    
    posi = T
    Set p1 = Range("E2")
    Set p2 = Range("E1")
    
    fg1 = True
    fg2 = True

    ReDim list(1 To 15, 1 To 7)
    
    Do While fg1 And fg2
        If count Mod 6 = 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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            
            End If
        
        End If

        Call keyInput

        
        Sleep 100
        count = count + 1
        DoEvents

        
    Loop
    

    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 = RGB(255, 0, 0)
            p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone

        ElseIf fg2 Then

            p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
            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 Sub

Sub 回転()

    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 = RGB(0, 0, 255)
                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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                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 = RGB(255, 0, 0)
                    p2.Interior.color = RGB(0, 0, 255)
                    posi = B
                Else
                    p2.Interior.ColorIndex = xlNone
                    Set p1 = p1.Offset(-1, 0)
                    Set p2 = p1.Offset(1, 0)
                    p1.Interior.color = RGB(255, 0, 0)
                    p2.Interior.color = RGB(0, 0, 255)
                    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 = RGB(0, 0, 255)
                posi = B
                
            Else
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(-1, 0)
                Set p2 = p1.Offset(1, 0)
                p1.Interior.color = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                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 = RGB(0, 0, 255)
                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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                posi = R
                
                bKey = vbKeyA
            '両方空いていないが前回入力が回転の場合クイック
            ElseIf bKey = vbKeyA Then
            

                Set p1 = p1.Offset(1, 0)
                Set p2 = p1.Offset(-1, 0)
                p1.Interior.color = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                posi = T
                
                bKey = 0
            Else
                bKey = vbKeyA
            
            End If
        
        
        Case L
            
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(-1, 0)
            p2.Interior.color = RGB(0, 0, 255)
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
                
            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 = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            End If
    End Select

End Sub


Sub keyInput()

    If count - bCount > 6 Then
        bKey = 0
    End If
    
    If GetAsyncKeyState(vbKeyA) Then
        Call 回転
        bCount = count
        'bKey = vbKeyA
        
    ElseIf GetAsyncKeyState(vbKeyRight) Then
        Call 移動(1)
        bCount = count
        bKey = vbKeyRight
    ElseIf GetAsyncKeyState(vbKeyLeft) Then
        Call 移動(-1)
        bCount = count
        bKey = vbKeyLeft
'    Else
'        bKey = 0
    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
    
    If x < 7 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

End Sub

この記事が気に入ったらサポートをしてみませんか？