Private Declare Function GetTickCount Lib "kernel32" () As Long 'this function lets us not use timer'timers are bad :)
'main body... each part of the snake has X and Y
Private Type Part
X As Integer
Y As Integer
End Type
'Dynamic array to store part coordinates
Dim Part() As Part
'Velocity in X and Y direction of the snake
Dim vX As Integer, vY As Integer
Dim i As Integer 'for loops
Dim CS As Single 'cell size
Dim FX As Integer, FY As Integer 'food coordinates
Dim X As Integer, Y As Integer
Dim bRunning As Boolean, died As Boolean
Private Sub Form_Load()
Randomize 'random generation
'Initialize controls******************
Picture1.BackColor = vbWhite
Picture1.ScaleMode = 3 'pixels
CS = 20 'cell size in pixels
X = Int(Picture1.ScaleWidth / CS)
Y = Int(Picture1.ScaleHeight / CS)
Picture1.AutoRedraw = True
Picture1.ScaleWidth = X * CS
Picture1.ScaleHeight = Y * CS
Me.WindowState = 2
Me.Show
DrawGrid Picture1, CS
'*************************************
died = False
'set up the game
ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0
FX = Int(Rnd * X)
FY = Int(Rnd * Y)
'go to main loop
bRunning = True
MainLoop
End Sub
Sub MainLoop()
Do While bRunning = True
Update
Draw
WAIT (50) 'increasing this number makes game slower
Loop
Unload Me
End Sub
Sub Update()
'MOVE PARTS
For i = UBound(Part) To 1 Step -1
Part(i).X = Part(i - 1).X
Part(i).Y = Part(i - 1).Y
Next i
'MOVE HEAD
Part(0).X = Part(0).X + vX
Part(0).Y = Part(0).Y + vY
'HAS HE GONE OUT OF BOUNDS ?
If Part(0).X <>= X Or Part(0).Y <>= Y Then
died = True
End If
'HAS HE CRASHED INTO HIMSELF ?
For i = 1 To UBound(Part)
If Part(i).X = Part(0).X And Part(i).Y = Part(0).Y Then
died = True
End If
Next i
'DID HE EAT FOOD ?
If Part(0).X = FX And Part(0).Y = FY Then
ReDim Preserve Part(UBound(Part) + 1)
Part(UBound(Part)).X = -CS
Part(UBound(Part)).Y = -CS
FX = Int(Rnd * X)
FY = Int(Rnd * Y)
Form1.Caption = "Parts: " & UBound(Part)
End If
'IS HE DEAD ?
If died = True Then NewGame
End Sub
Sub Draw()
'DRAW WHITENESS
Rectangle 0, 0, X * CS, Y * CS, vbWhite
'DRAW SNAKE. PARTS IN BLUE, HEAD IN GREEN
For i = 1 To UBound(Part)
Rectangle Part(i).X * CS, Part(i).Y * CS, Part(i).X * CS + CS, Part(i).Y * CS + CS, vbBlue
Next i
Rectangle Part(0).X * CS, Part(0).Y * CS, Part(0).X * CS + CS, Part(0).Y * CS + CS, vbGreen
'DRAW FOOD
Rectangle FX * CS, FY * CS, FX * CS + CS, FY * CS + CS, vbRed
DrawGrid Picture1, CS
End Sub
Sub Rectangle(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, color As Long)
Picture1.Line (X1, Y1)-(X2, Y2), color, BF
End Sub
Sub NewGame()
'SET UP NEW GAME
died = False
ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0
vX = 0
vY = 0
FX = Int(Rnd * X)
FY = Int(Rnd * Y)
End Sub
Sub DrawGrid(Pic As Control, CS As Single)
'**************************************************************************
'DRAW GRID
'**************************************************************************
Dim i As Integer, Across As Single, Up As Single
Across = Pic.ScaleWidth / CS
Up = Pic.ScaleHeight / CS
For i = 0 To Across
Pic.Line (i * CS, 0)-(i * CS, Up * CS)
Next i
For i = 0 To Up
Pic.Line (0, i * CS)-(Across * CS, i * CS)
Next i
End Sub
Sub WAIT(Tim As Integer)
'**************************************************************************
'WAIT FUNCTION
'**************************************************************************
Dim LastWait As Long
LastWait = GetTickCount
Do While Tim > GetTickCount - LastWait
DoEvents
Loop
End Sub
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
'USER KEYPRESSES HANDLED HERE
Select Case KeyCode
Case vbKeyRight
vX = 1
vY = 0
Case vbKeyLeft
vX = -1
vY = 0
Case vbKeyUp
vX = 0
vY = -1
Case vbKeyDown
vX = 0
vY = 1
End Select
End Sub
Private Sub Picture1_KeyPress(KeyAscii As Integer)
'27 is ESC. IF user presses ESC, QUIT
If KeyAscii = 27 Then bRunning = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
'This function can be left out
End
End Sub
Option Explicit
