Excelでテトリス 1

　前回に引き続きExcelでタイマー処理を使って遊んでます。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。

----------
2020/6/13 : Version 1
2020/7/24 : ちょっとだけオリジナリティを出すため、周期的境界条件にしてみました

----------

Option Explicit

'--------------------------------------------------
'                   APIの宣言
'--------------------------------------------------
'DWORD timeGetTime( VOID);
Public Declare PtrSafe Function timeGetTime Lib "WINMM.DLL" () As Long

'SHORT GetAsyncKeyState( int vKey);
Public Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
Public Const VK_ENTER As Integer = 13
Public Const VK_ESC As Integer = 27
Public Const VK_SPACE As Integer = 32
Public Const VK_LEFT As Integer = 37
Public Const VK_UP As Integer = 38
Public Const VK_RIGHT As Integer = 39
Public Const VK_DOWN As Integer = 40

'VOID Sleep( DWORD dwMilliseconds);
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'BOOL sndPlaySound( LPCSTR lpszSound, UINT fuSound);
Public Declare PtrSafe Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Const SND_SYNC = &H0
Public Const SND_ASYNC = &H1
Public Const SND_NODEFAULT = &H2
Public Const SND_LOOP = &H8
Public Const SND_NOSTOP = &H10
'--------------------------------------------------

Private Const width As Long = 10
Private Const height As Long = 20
Private Const speed As Long = 4     'Game Speed (speed x 100 msec毎にブロックが落下)

Private block(width * height - 1) As Byte

Private drop_id As Byte
Private drop_x(3) As Byte
Private drop_y(3) As Byte

Private counter As Long

Public Sub Tetris()
    Dim timeNext As Long
    Dim loopFlag As Boolean
   
    timeNext = timeGetTime
    loopFlag = True
   
    Call init
   
    '----- メインループ -----
    Do While loopFlag = True
        If timeNext < timeGetTime Then
            Call run
           
            Call draw
           
            '----- ESC Keyで終了 -----
            If GetAsyncKeyState(VK_ESC) <> 0 Or counter = -1 Then
                loopFlag = False
            End If
       
            '-------------------------
            timeNext = timeNext + 100
        End If
       
        '-------------------------
        Sheet1.Cells(1, 1).Select
        DoEvents
    Loop
    '------------------------
End Sub

'初期化
Private Sub init()
    Dim i As Long
   
    Sheet1.Cells.Delete
   
    '------------------------
    '行の高さ、列の幅を調整
    For i = 0 To height - 1
        Sheet1.Rows(i + 1).RowHeight = 13.5
    Next i
   
    For i = 0 To width - 1
        Sheet1.Columns(i + 1).ColumnWidth = 2.095
    Next i
   
    '------------------------
    For i = 0 To width * height - 1
        block(i) = 0
    Next i
   
    '------------------------
    Call create
    counter = 0
End Sub

Private Sub create()
    Dim i As Long
   
    drop_id = Int(7 * Rnd() + 1)
   
    For i = 0 To 3
        drop_x(i) = width / 2
        drop_y(i) = height - 2
    Next i
   
    'I, O, S, Z, J, L, T
    If drop_id = 1 Then
        '----- I -----
        drop_y(1) = drop_y(1) + 1
        drop_y(2) = drop_y(2) - 1
        drop_y(3) = drop_y(3) - 2
    ElseIf drop_id = 2 Then
        '----- O -----
        drop_x(1) = drop_x(1) + 1
        drop_y(2) = drop_y(2) + 1
        drop_x(3) = drop_x(3) + 1
        drop_y(3) = drop_y(3) + 1
    ElseIf drop_id = 3 Then
        '----- S -----
        drop_x(1) = drop_x(1) - 1
        drop_y(2) = drop_y(2) + 1
        drop_x(3) = drop_x(3) + 1
        drop_y(3) = drop_y(3) + 1
    ElseIf drop_id = 4 Then
        '----- Z -----
        drop_x(1) = drop_x(1) - 1
        drop_y(1) = drop_y(1) + 1
        drop_y(2) = drop_y(2) + 1
        drop_x(3) = drop_x(3) + 1
    ElseIf drop_id = 5 Then
        '----- J -----
        drop_x(1) = drop_x(1) - 1
        drop_x(2) = drop_x(2) + 1
        drop_x(3) = drop_x(3) - 1
        drop_y(3) = drop_y(3) + 1
    ElseIf drop_id = 6 Then
        '----- L -----
        drop_x(1) = drop_x(1) - 1
        drop_x(2) = drop_x(2) + 1
        drop_x(3) = drop_x(3) + 1
        drop_y(3) = drop_y(3) + 1
    ElseIf drop_id = 7 Then
        '----- T -----
        drop_x(1) = drop_x(1) - 1
        drop_x(2) = drop_x(2) + 1
        drop_y(3) = drop_y(3) + 1
    End If
End Sub

Private Sub run()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim temp_x(3) As Long
    Dim temp_y(3) As Long
   
    'キー入力
    Call run_key
   
    If 0 < counter Then
        counter = (counter + 1) Mod speed
        Exit Sub
    End If
   
    '落下処理
    For i = 0 To 3
        temp_x(i) = CLng(drop_x(i))
        temp_y(i) = CLng(drop_y(i)) - 1
    Next i
   
    If move(temp_x, temp_y) = True Then
        counter = 1
        Exit Sub
    End If
   
    For i = 0 To 3
        block(drop_y(i) * width + drop_x(i)) = drop_id
    Next i
   
    '消去処理
    For i = 0 To height - 1
        For j = 0 To width - 1
            If block(i * width + j) = 0 Then
                Exit For
            End If
        Next j
       
        If j = width Then
            For j = 0 To width - 1
                For k = i To height - 2
                    block(k * width + j) = block((k + 1) * width + j)
                Next k
               
                block((height - 1) * width + j) = 0
            Next j
           
            i = i - 1
        End If
    Next i
   
    'Game Overの確認
    If block((height - 2) * width + width / 2) <> 0 Then
        counter = -1
        Exit Sub
    End If
   
    Call create
    counter = 0
End Sub

Private Sub run_key()
    Dim i As Long
    Dim temp_x(3) As Long
    Dim temp_y(3) As Long
   
    '---------- left ----------
    If GetAsyncKeyState(VK_LEFT) <> 0 Then
        For i = 0 To 3
            temp_x(i) = (CLng(drop_x(i)) - 1 + width) Mod width
            temp_y(i) = CLng(drop_y(i))
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- up ----------
    If GetAsyncKeyState(VK_UP) <> 0 Then
        For i = 0 To 3
            temp_x(i) = (CLng(drop_x(0)) - drop_y(i) + drop_y(0) + width) Mod width
           
            temp_y(i) = CLng(drop_x(i)) - drop_x(0)
           
            '周期的境界条件の、周期にまたがっている場合
            If Math.Abs(CLng(drop_x(i)) - width - drop_x(0)) < Math.Abs(temp_y(i)) Then
                temp_y(i) = CLng(drop_x(i)) - width - drop_x(0)
            End If
           
            If Math.Abs(CLng(drop_x(i)) + width - drop_x(0)) < Math.Abs(temp_y(i)) Then
                temp_y(i) = CLng(drop_x(i)) + width - drop_x(0)
            End If
           
            temp_y(i) = CLng(drop_y(0)) + temp_y(i)
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- right ----------
    If GetAsyncKeyState(VK_RIGHT) <> 0 Then
   
        For i = 0 To 3
            temp_x(i) = (CLng(drop_x(i)) + 1) Mod width
            temp_y(i) = CLng(drop_y(i))
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- down ---------
    If GetAsyncKeyState(VK_DOWN) <> 0 Then
   
        For i = 0 To 3
            temp_x(i) = CLng(drop_x(i))
            temp_y(i) = CLng(drop_y(i)) - 1
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '------------------------
End Sub

Private Function move(temp_x() As Long, temp_y() As Long) As Boolean
    Dim i As Long
    Dim flag As Boolean
   
    flag = True
   
    For i = 0 To 3
        If temp_x(i) < 0 Or width - 1 < temp_x(i) Then
            flag = False
            Exit For
        End If
       
        If temp_y(i) < 0 Or height - 1 < temp_y(i) Then
            flag = False
            Exit For
        End If
       
        If block(temp_y(i) * width + temp_x(i)) <> 0 Then
            flag = False
            Exit For
        End If
    Next i
   
    If flag = True Then
        For i = 0 To 3
            drop_x(i) = CByte(temp_x(i))
            drop_y(i) = CByte(temp_y(i))
        Next i
    End If
   
    move = flag
End Function

Private Sub draw()
    Dim i As Long
    Dim j As Long
    Dim temp() As Byte
   
    ReDim temp(width * height - 1) As Byte
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            temp(i * width + j) = 32
           
            If 0 < block(i * width + j) Then
                temp(i * width + j) = 96 + block(i * width + j)
            End If
        Next j
    Next i
   
    For i = 0 To 3
        temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id
    Next i
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            Sheet1.Cells(height - i, j + 1) = Chr(temp(i * width + j))
        Next j
    Next i
End Sub