Excelでぷよぷよ

　テトリスを作ったらぷよぷよも。ということで、作ってみました。

　実際に作ってみると、操作性とか、プログラムに大きく依存することがわかります。面白いゲームにするにはいろいろと調整が必要そうです。
　最近はe-sportsが話題に上りますが、ソフトウェアの仕様に影響されちゃうんだろうなぁ、と思います。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。プログラミングを勉強しているどなたかの参考にでもなれば幸いです。


----------
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 key(5) As Byte  'キー入力を保存するバッファ
Private key_enable(5) As Boolean

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

Private block(width * height - 1) As Byte
Private remove(width * height - 1) As Byte

Private next_id(1) As Byte

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

Private mode As Long
Private counter As Long

Public Sub puyo()
    Dim timeNext As Long
    Dim loopFlag As Boolean
   
    timeNext = timeGetTime
    loopFlag = True
   
    Call init
   
    '----- メインループ -----
    Do While loopFlag = True
        If timeNext < timeGetTime Then
            If mode = 1 Then
                Call run1
            ElseIf mode = 2 Then
                Call run2
            ElseIf mode = 3 Then
                Call run3
            End If
           
            Call draw
           
            '----- ESC Keyで終了 -----
            If GetAsyncKeyState(VK_ESC) <> 0 Or mode = -1 Then
                loopFlag = False
            End If
           
            If GetAsyncKeyState(VK_LEFT) <> 0 Then
                Call key_on(0)
            Else
                Call key_off(0)
            End If
   
            If GetAsyncKeyState(VK_UP) <> 0 Then
                Call key_on(1)
            Else
                Call key_off(1)
            End If
   
            If GetAsyncKeyState(VK_RIGHT) <> 0 Then
                Call key_on(2)
            Else
                Call key_off(2)
            End If
   
            If GetAsyncKeyState(VK_DOWN) <> 0 Then
                Call key_on(3)
            Else
                Call key_off(3)
            End If
           
            '-------------------------
            timeNext = timeNext + 100
        End If
       
        '-------------------------
        Sheet1.Cells(1, 1).Select
        DoEvents
    Loop
    '------------------------
End Sub

Private Sub key_on(id As Long)
    key(id) = key(id) + 1
   
    If 4 < key(id) Then
        key(id) = 4
        key_enable(id) = True
    End If
End Sub

Private Sub key_off(id As Long)
    key(id) = 0
    key_enable(id) = True
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 + 1
        Sheet1.Columns(i + 1).ColumnWidth = 2.095
    Next i
   
    '------------------------
    For i = 0 To width * height - 1
        block(i) = 0
    Next i
   
    '------------------------
    key(0) = 0
    key(1) = 0
    key(2) = 0
    key(3) = 0
   
    key_enable(0) = True
    key_enable(1) = True
    key_enable(2) = True
    key_enable(3) = True
    '------------------------
    Call create
    Call create
   
    mode = 1
    counter = 0
End Sub

Private Sub create()
    drop_id(0) = next_id(0)
    drop_id(1) = next_id(1)
   
    next_id(0) = Int(5 * Rnd() + 1)
    next_id(1) = Int(5 * Rnd() + 1)
   
    drop_x(0) = width / 2
    drop_y(0) = height - 2
    drop_x(1) = width / 2
    drop_y(1) = height - 1
End Sub

Private Sub run1()
    Dim i As Long
    Dim temp_x(1) As Long
    Dim temp_y(1) As Long
   
    'キー入力
    Call run_key
   
    If 0 < counter Then
        counter = (counter + 1) Mod speed
        Exit Sub
    End If
   
    '落下処理
    For i = 0 To 1
        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 1
        block(drop_y(i) * width + drop_x(i)) = drop_id(i)
    Next i
   
    mode = 2
    counter = height
End Sub

Private Sub run2()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim id As Byte

    If counter = height Then
        counter = 1
        Exit Sub
    End If
   
    '------------------------
    'ブロックの落下
    For i = 0 To width - 1
        For j = 0 To height - 2
            If block(j * width + i) = 0 And 0 < block((j + 1) * width + i) Then
                For k = j To height - 2
                    block(k * width + i) = block((k + 1) * width + i)
                Next k
               
                counter = 0
                block((height - 1) * width + i) = 0
                j = j - 1
            End If
        Next j
    Next i
   
    If counter = 0 Then
        counter = 1
        Exit Sub
    End If
   
    '------------------------
    'ブロックのつながりを数える
    For i = 0 To height - 1
        For j = 0 To width - 1
            remove(i * width + j) = 0
        Next j
    Next i
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            counter = 0
            id = block(i * width + j) Mod 8
            Call count(j, i, id)
            Call note(j, i, id)
           
            'ブロックのつながりを表示
            'Sheet1.Cells(2 * height + 4 - i, 1 + j) = remove(i * width + j)
        Next j
    Next i
   
    counter = 1
   
    '------------------------
    '消去処理
    For i = 0 To height - 1
        For j = 0 To width - 1
            If 0 < block(i * width + j) And 3 < remove(i * width + j) Then
                block(i * width + j) = 0
                counter = 0
            End If
        Next j
    Next i
   
    If counter = 0 Then
        counter = height
        Exit Sub
    End If
   
    'Game Overの確認
    If block((height - 2) * width + width / 2) <> 0 Then
        mode = 3
        counter = height
        Exit Sub
    End If

    Call create
    mode = 1
    counter = 0
End Sub

Private Sub count(x As Long, y As Long, id As Byte)
    If (block(y * width + x) And 8) = 0 And block(y * width + x) Mod 8 = id And remove(y * width + x) = 0 Then
        counter = counter + 1
        block(y * width + x) = block(y * width + x) + 8 '数え中の印をつける

        If 0 < x Then Call count(x - 1, y, id)
        If 0 < y Then Call count(x, y - 1, id)
        If x < width - 1 Then Call count(x + 1, y, id)
        If y < height - 1 Then Call count(x, y + 1, id)
    End If
End Sub

Private Sub note(x As Long, y As Long, id As Byte)
    If 0 < (block(y * width + x) And 8) And block(y * width + x) Mod 8 = id Then
        remove(y * width + x) = counter
        block(y * width + x) = block(y * width + x) - 8 '数え中の印を消す

        If 0 < x Then Call note(x - 1, y, id)
        If 0 < y Then Call note(x, y - 1, id)
        If x < width - 1 Then Call note(x + 1, y, id)
        If y < height - 1 Then Call note(x, y + 1, id)
    End If
End Sub

Private Sub run3()
    Dim i As Long
    Dim j As Long

    If 0 < counter Then
        For i = 0 To height - 2
            For j = 0 To width - 1
                block(i * width + j) = block((i + 1) * width + j)
            Next j
        Next i
       
        For j = 0 To width - 1
            block((height - 1) * width + j) = 0
        Next j
       
        counter = counter - 1
        Exit Sub
    End If

    mode = -1
End Sub

Private Sub run_key()
    Dim i As Long
    Dim temp_x(1) As Long
    Dim temp_y(1) As Long
   
    '---------- left ----------
    If 0 < key(0) And key_enable(0) = True Then
        key_enable(0) = False
       
        For i = 0 To 1
            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 0 < key(1) And key_enable(1) = True Then
        key_enable(1) = False
       
        For i = 0 To 1
            'temp_x(i) = CLng(drop_x(0)) + drop_y(i) - drop_y(0)
            'temp_y(i) = CLng(drop_y(0)) - drop_x(i) + drop_x(0)
           
            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 0 < key(2) And key_enable(2) = True Then
        key_enable(2) = False
       
        For i = 0 To 1
            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 0 < key(3) And key_enable(3) = True Then
        key_enable(3) = False
       
        For i = 0 To 1
            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 1
        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 1
            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
            If 0 < (block(i * width + j) Mod 8) Then
                temp(i * width + j) = 96 + block(i * width + j) Mod 8
            Else
                temp(i * width + j) = 32
            End If
        Next j
    Next i
   
    If mode = 1 Then
        For i = 0 To 1
            temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id(i)
        Next i
    End If
   
    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
   
    '------------------------
    Sheet1.Cells(2, width + 1) = Chr(96 + next_id(0))
    Sheet1.Cells(1, width + 1) = Chr(96 + next_id(1))
End Sub

Excelでテトリス 2

　前回作ったテトリスは、非常にシンプルな作りでした。それじゃ味気ないので、少しアニメーションとかをつけてみました。

　キー入力もバッファを使ってます。バッファを使わないと、一度で2回キー入力処理がされているみたいになることがあります。こういったハードウェアに近いところの処理は奥が深いなぁと思います。

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

----------

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

'---------- キー入力の注意事項 ----------
'_______kkk______kkk_____   (k : キーが押されているタイミング)
'_____p_____p_____p_____p   (p : キー処理のタイミング (2,3番目のpだけ処理されるようにしたい))

'キー処理とキー処理の間でキーが押されてもキー処理されるようにキー入力を保存する
'(今回のプログラムでは、キー処理とGetAsyncKeyState関数が同じタイミングなので、回数に意味はない)

'1回のキー入力を2回と誤判定しないように、キー処理終了後から次のGetAsyncKeyState関数まではキー処理を無効にする

'本当はGetAsyncKeyState関数の戻り値で、"キーが押されているか"と"それまでにキーが押されたか"が分かるらしい。。。
'----------------------------------------
Private key(5) As Byte  'キー入力を保存するバッファ
Private key_enable(5) As Boolean

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 remove(height - 1) As Byte

Private next_id As Byte
Private next_x(3) As Byte
Private next_y(3) As Byte

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

Private mode As Long
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
            If mode = 1 Then
                Call run1
            ElseIf mode = 2 Then
                Call run2
            ElseIf mode = 3 Then
                Call run3
            End If
           
            Call draw
           
            '----- ESC Keyで終了 -----
            If GetAsyncKeyState(VK_ESC) <> 0 Or mode = -1 Then
                loopFlag = False
            End If
           
            If GetAsyncKeyState(VK_LEFT) <> 0 Then
                Call key_on(0)
            Else
                Call key_off(0)
            End If
   
            If GetAsyncKeyState(VK_UP) <> 0 Then
                Call key_on(1)
            Else
                Call key_off(1)
            End If
   
            If GetAsyncKeyState(VK_RIGHT) <> 0 Then
                Call key_on(2)
            Else
                Call key_off(2)
            End If
   
            If GetAsyncKeyState(VK_DOWN) <> 0 Then
                Call key_on(3)
            Else
                Call key_off(3)
            End If
   
            '-------------------------
            timeNext = timeNext + 100
        End If
   
        '-------------------------
        Sheet1.Cells(1, 1).Select
        DoEvents
    Loop
    '------------------------
End Sub

Private Sub key_on(id As Long)
    key(id) = key(id) + 1
   
    If 4 < key(id) Then
        key(id) = 4
        key_enable(id) = True
    End If
End Sub

Private Sub key_off(id As Long)
    key(id) = 0
    key_enable(id) = True
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 + 3
        Sheet1.Columns(i + 1).ColumnWidth = 2.095
    Next i
   
    '------------------------
    For i = 0 To width * height - 1
        block(i) = 0
    Next i
   
    '------------------------
    key(0) = 0
    key(1) = 0
    key(2) = 0
    key(3) = 0
   
    key_enable(0) = True
    key_enable(1) = True
    key_enable(2) = True
    key_enable(3) = True
    '------------------------
    Call create
    Call create
   
    mode = 1
    counter = 0
End Sub

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

Private Sub run1()
    Dim i 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
   
    mode = 2
    counter = width / 2
End Sub

Private Sub run2()
    Dim i As Long
    Dim j As Long
    Dim k As Long
   
    '消去する行に印をつける
    If counter = width / 2 Then
        counter = 0
       
        For i = 0 To height - 1
            remove(i) = 0
           
            For j = 0 To width - 1
                If block(i * width + j) = 0 Then
                    Exit For
                End If
            Next j
           
            If j = width Then
                remove(i) = 1
                counter = width / 2
            End If
        Next i
    End If
   
    'ブロック消去のアニメーション
    If 0 < counter Then
        For i = 0 To height - 1
            If remove(i) = 1 Then
                block(i * width + counter - 1) = 0
                block(i * width + width - counter) = 0
            End If
        Next i
       
        counter = counter - 1
        Exit Sub
    End If
   
    '消去処理
    For i = 0 To height - 1
        If remove(i) = 1 Then
            '------------------------
            For k = 0 To height - 2
                remove(k) = remove(k + 1)
            Next k
           
            remove(height - 1) = 0
           
            '------------------------
            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
        mode = 3
        counter = height
        Exit Sub
    End If
   
    Call create
    mode = 1
    counter = 0
End Sub

Private Sub run3()
    Dim i As Long
   
    If 0 < counter Then
        For i = 0 To width - 1
            block((height - counter) * width + i) = Int(7 * Rnd() + 1)
        Next i
       
        counter = counter - 1
        Exit Sub
    End If
   
    mode = -1
End Sub

Private Sub run_key()
    Dim i As Long
    Dim temp_x(3) As Long
    Dim temp_y(3) As Long
   
    '---------- left ----------
    If 0 < key(0) And key_enable(0) = True Then
        key_enable(0) = False
       
        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 0 < key(1) And key_enable(1) = True Then
        key_enable(1) = False
       
        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 0 < key(2) And key_enable(2) = True Then
        key_enable(2) = False
       
        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 0 < key(3) And key_enable(3) = True Then
        key_enable(3) = False
       
        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
   
    If mode = 1 Then
        For i = 0 To 3
            temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id
        Next i
    End If
   
    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
   
    '------------------------
    ReDim temp(3 * 4 - 1) As Byte
   
    For i = 0 To 3
        For j = 0 To 2
            temp(i * 3 + j) = 32
        Next j
    Next i
   
    For i = 0 To 3
        temp((next_y(i) + 2 - (height - 2)) * 3 + (next_x(i) + 1 - (width / 2))) = 96 + next_id
    Next i
   
    For i = 0 To 3
        For j = 0 To 2
            Sheet1.Cells(5 - i, 11 + j) = Chr(temp(i * 3 + j))
        Next j
    Next i
End Sub

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

Excelでライフゲーム

　前回、Excelでタイマー処理をするサンプルを作ったので、今回はそれを利用して、ライフゲームを作ってみました。
　Excelのセルを見続けていると、こんな感じで遊びたくなるのが普通です。たぶん。。。

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



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 = 10
Private block(width * height - 1) As Byte '0 or 1

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

'初期化
Private Sub init()
    Dim i As Long
    Dim j As Long
 
    '------------------------
    '行の高さ、列の幅を調整
    For i = 0 To width - 1
        Sheet1.Columns(i + 1).ColumnWidth = 2.095
    Next i
 
    For i = 0 To height - 1
        Sheet1.Rows(i + 1).RowHeight = 13.5
    Next i
 
    '------------------------
    '適当なサンプル
    Sheet1.Cells(4, 5) = "a"
    Sheet1.Cells(5, 5) = "a"
    Sheet1.Cells(6, 5) = "a"
    Sheet1.Cells(7, 5) = "a"
    Sheet1.Cells(8, 5) = "a"
 
    '------------------------
    For i = 0 To height - 1
        For j = 0 To width - 1
            block(i * width + j) = 0
         
            If Sheet1.Cells(i + 1, j + 1) = "a" Then
                block(i * width + j) = 1
            End If
        Next j
    Next i
End Sub

'メインループの処理
Private Sub run()
    Dim i As Long
    Dim j As Long
    Dim pos 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) = 0
        Next j
    Next i
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = ((i + height - 1) Mod height) * width + ((j + width - 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = ((i + height - 1) Mod height) * width + j
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = ((i + height - 1) Mod height) * width + ((j + 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = i * width + ((j + width - 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = i * width + ((j + 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = ((i + 1) Mod height) * width + ((j + width - 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = ((i + 1) Mod height) * width + j
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
         
            pos = ((i + 1) Mod height) * width + ((j + 1) Mod width)
            If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
        Next j
    Next i
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            If block(i * width + j) = 0 Then
                If temp(i * width + j) = 3 Then
                    block(i * width + j) = 1
                End If
            ElseIf block(i * width + j) = 1 Then
                If temp(i * width + j) < 2 Or 3 < temp(i * width + j) Then
                    block(i * width + j) = 0
                End If
            End If
        Next j
    Next i
 
    '------------------------
    '描画
    For i = 0 To height - 1
        For j = 0 To width - 1
            If block(i * width + j) = 1 Then
                Sheet1.Cells(i + 1, j + 1) = "a"
            Else
                'なぜか知らないけど、空文字列""だと動作が遅くなるみたい
                Sheet1.Cells(i + 1, j + 1) = " "
            End If
        Next j
    Next i
End Sub

Excelでタイマー処理

　ExcelでWindows APIを使うのはあまり好きではないのですが、Windows APIを使うからこそできることもあります。
　てなわけで、暇つぶしにWindos APIのタイマーを使ってみたサンプルです。
　waitTime関数はただ時間を待つだけです。loopTest関数はひたすら無限ループします。

　まぁ、次回以降のおもちゃを作るための準備なんですが。。。

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



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

Public Sub timerTest()
    waitTime (3000)
    MsgBox "waited 3 sec"
End Sub

Public Sub clear()
    Sheet1.Cells.Delete
End Sub

Public Function waitTime(timeToWait As Integer)
    Dim timeNext As Long
    timeNext = timeGetTime() + timeToWait
 
    '----- ループ -----
    Do While timeGetTime() < timeNext
        'Sheet1.Cells(1, 1).Select
        DoEvents
    Loop
    '------------------
End Function

Public Function playSound(SoundName As String)
    Dim wFlags As Long
 
    wFlags = SND_ASYNC Or SND_NODEFAULT
    playSound = sndPlaySound(SoundName, wFlags)
End Function

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