テトリスを作ったらぷよぷよも。ということで、作ってみました。
実際に作ってみると、操作性とか、プログラムに大きく依存することがわかります。面白いゲームにするにはいろいろと調整が必要そうです。
最近は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
2020年6月13日土曜日
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
キー入力もバッファを使ってます。バッファを使わないと、一度で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
例によって、動作保証はしませんが、ソースコードはご自由にお使いください。
----------
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のセルを見続けていると、こんな感じで遊びたくなるのが普通です。たぶん。。。
例によって、動作保証はしませんが、ソースコードはご自由にお使いください。
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
てなわけで、暇つぶしに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
登録:
投稿 (Atom)