前回に引き続き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
0 件のコメント:
コメントを投稿