извините, не нашел нужной ветки.
пример игры в Excel (просто хочется определить дату создания мною игры (правда написал я ее еще 3 года назад...)) ;)
файл UserForm1
| Код |
Dim snake() As Class1
Dim food As New Class1
Dim source As Integer
Dim pause As Single, pause2 As Single
Private Sub Frame1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
setSource (KeyAscii) ' передаем код нажатой клавиши в функцию
End Sub
Private Function setSource(ByRef k As Integer)
Select Case k
Case 65
source = 1
Case 97
source = 1
Case 52
source = 1
Case 87
source = 2
Case 119
source = 2
Case 56
source = 2
Case 68
source = 3
Case 100
source = 3
Case 54
source = 3
Case 83
source = 4
Case 115
source = 4
Case 53
source = 4
End Select
End Function
Public Function moveSnake() ' функция перемещения змеи
Dim head As Class1, tail As Class1
Set head = snake(0)
Set tail = snake(UBound(snake) - 1) ' последний элемент массива
Dim x As Integer, y As Integer
x = head.getX
y = head.getY
Select Case source ' что бы не перерисовывать всю змею,
' берем последний элемент массива,
' и перемещаем его на место первого
' с новыми координатами
Case 1
tail.setLocation x - 10, y
Case 2
tail.setLocation x, y - 10
Case 3
tail.setLocation x + 10, y
Case 4
tail.setLocation x, y + 10
End Select
head.setColor 120, 170, 255 ' меняем цвет головы
tail.setColor 255, 120, 170 ' меняем цвет хвоста
For i = UBound(snake) - 1 To 1 Step -1 ' смещаем элементы массива
Set snake(i) = snake(i - 1)
Next i
Set snake(0) = tail ' последний элемент массива делаем первым
gameOver ' проверка
eat ' проверка
End Function
Private Function goSnake()
Dim time As Single
time = Timer
pause = 0.5 ' скорость змеи
pause2 = 20 ' частота перемещения еды
While Not gameOver
DoEvents ' VBA не приспособлен для потоков Thread
If (time + pause < Timer) Then
moveSnake
time = Timer
End If
Wend
End Function
Private Function gameOver() As Boolean
Dim head As Class1
Set head = snake(0)
Dim x As Integer, y As Integer
x = head.getX
y = head.getY
If (x < 0 Or x >= 300 Or y < 0 Or y >= 300) Then
MsgBox "out"
gameOver = True
End If
Dim tx As Integer, ty As Integer
If UBound(snake) > 2 Then
For i = 2 To UBound(snake) - 1
tx = snake(i).getX
ty = snake(i).getY
If tx = x And ty = y Then
MsgBox "съел себя"
gameOver = True
End If
Next i
End If
If gameOver = True Then
source = 0
Erase snake
ReDim snake(0)
End If
End Function
Private Sub StartButton1_Click()
Frame1.Controls.Clear
ReDim snake(0)
startGame
End Sub
Private Sub UserForm_Activate()
createGameField
End Sub
Private Function createGameField() ' размер формы и игрового поля
With UserForm1
.Width = 450
.Height = 350
End With
With Frame1
.Width = 302
.Height = 302
.Left = 10
.Top = 10
End With
End Function
Function startGame()
MsgBox "Управляющие клавиши:" & Chr(13) & " a w d s" & Chr(13) & _
"или" & Chr(13) & " A W D S" & Chr(13) & _
"или" & Chr(13) & " 4 8 6 5"
food.SnakePart 0, 0, 0, 255, 0
showFood
ReDim snake(1)
Dim head As New Class1
head.SnakePart 0, 0, 255, 120, 170
Set snake(0) = head
source = 0
Frame1.SetFocus ' без этого не будут работать управляющие клавиши
' (фокус останется на кнопке)
goSnake
End Function
Public Function showFood() ' показать еду
Dim x As Integer, y As Integer
x = ((Rnd() * (300 - 10) + 1) \ 10) * 10 ' еда будет появляться
y = ((Rnd() * (300 - 10) + 1) \ 10) * 10 ' в координатах, кратных 10 _
'(10 - размер части тела змеи)
' и внутри игрового поля
food.setLocation x, y
Application.OnTime Now + TimeValue("00:00:" & Str(pause2)), _
"Module1.Food" ' здесь доли секунды не нужны
End Function
Private Function eat() ' попала ли голова на еду
Dim head As Class1
Set head = snake(0)
If head.getX = food.getX And head.getY = food.getY Then
food.setLocation -20, -20
addTail
End If
End Function
Private Function addTail() ' если поймали еду, добавляем хвост
Dim tail As New Class1, old_tail As Class1
Set old_tail = snake(UBound(snake) - 1)
ReDim Preserve snake(UBound(snake) + 1)
tail.SnakePart old_tail.getX, old_tail.getY, 120, 170, 255
Set snake(UBound(snake) - 1) = tail
Label2.Caption = UBound(snake) - 1
If ((UBound(snake) - 1) Mod 5 = 0 And pause >= 0.2) Then
pause = pause - 0.1 ' в зависимости от длины хвоста увеличиваем скорость змеи
pause2 = pause2 - 4
End If
End Function
|
файл Class1
| Код |
' класс хранит объект части змеи и его цвет
Dim part As Control
Sub SnakePart(ByRef x As Integer, ByRef y As Integer, ByRef r, _
ByRef g, ByRef b)
Set part = UserForm1.Frame1.Controls.Add("Forms.Label.1")
With part
.Width = 10
.Height = 10
.Left = x
.Top = y
.BackColor = RGB(r, g, b)
End With
End Sub
Public Function setLocation(ByRef x As Integer, ByRef y As Integer)
part.Left = x
part.Top = y
End Function
Public Function getX()
getX = part.Left
End Function
Public Function getY()
getY = part.Top
End Function
Public Function setColor(ByRef r, ByRef g, ByRef b)
part.BackColor = RGB(r, g, b)
End Function
|
файл Module1
| Код |
Sub Кнопка1_Щелчок()
UserForm1.Show
End Sub
Sub food()
UserForm1.showFood
End Sub
|
|
После нажатия "Enter" название листа изменится в соответствии с полем Name.
