Ubah Property Width menjadi 4335, Height menjadi 3855, Backcolor menjadi H00FFFFFF&. (
Deklarasi utamanya adalah sebagai :Code:
Const WarnaGrid = vbBlack
Const WarnaKepala = vbWhite
Const warnaTubuh = vbGreen
Const warnaMakanan = vbRed
Const warnaGaris = vbWhite
Private Declare Function GetTickCount Lib "kernel32" ()
As Long
Private Type Part
X As Integer
Y As Integer
End Type
Dim Part() As Part
Dim Level As Long
Dim vX As Integer, vY As Integer
Dim i As Integer
Dim CS As Single
Dim FX As Integer, FY As Integer
Dim X As Integer, Y As Integer
Dim bRunning As Boolean, died As Boolean
2. Inisialisasi dan event-event yang dicegat, pada saat game kali pertama dijalankan:
Code:
Private Sub Form_Load()
Randomize
Picture1.BackColor = warnaGaris
Picture1.ScaleMode = 3 'pixels
CS = 20
X = Int(Picture1.ScaleWidth / CS)
Y = = Int(Picture1.ScaleHeight / CS)
3. Subrutin lain yang dibutuhkan adalah:
Code:
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)
bRunning = True
Level = 1
Form1.Caption = "Score: " & UBound(Part) & " Level : "
& Level
MainLoop
End Sub
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift
As Integer)
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)
If KeyAscii = 27 Then bRunning = False
If KeyAscii = Asc("p") Then MsgBox "Pause"
End Sub
Sub MainLoop()
Do While bRunning = True
Update
Draw
WAIT (160 - Level * 10)
Loop
Unload Me
End Sub
Sub Update()
'menggerakkan tubuh
For i = UBound(Part) To 1 Step -1
Part(i).X = Part(i - 1).X
Part(i).Y = Part(i - 1).Y
Next i
'kepala
Part(0).X = Part(0).X + vX
Part(0).Y = Part(0).Y + vY
'menabrak pinggiran
If Part(0).X <>= X Or Part(0).Y <>= Y Then
died = True
End If
'menabrak diri sendiri
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
'makan
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)
If UBound(Part) Mod 20 = 0 Then Level = Level + 1
Form1.Caption = "Parts: " & UBound(Part) & " Level
: " & Level
End If
If died = True Then NewGame
End Sub
Sub Draw()
Rectangle 0, 0, X * CS, Y * CS, WarnaGrid
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, warnaTubuh
Next i
Rectangle Part(0).X * CS, Part(0).Y * CS, Part(0).X
* CS + CS, Part(0).Y * CS + CS, WarnaKepala
Rectangle FX * CS, FY * CS, FX * CS + CS, FY * CS +
CS, warnaMakanan
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()
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)
Dim i As Integer, Across As Single, Up As Single
Across = Pic.ScaleWidth / CS
Up = Pic.ScaleHeight / CS
For i = 0 To Across
Pic.ForeColor = warnaGaris
Pic.Line (i * CS, 0)-(i * CS, Up * CS)
Next
For i = 0 To Up
Pic.ForeColor = warnaGaris
Pic.Line (0, i * CS)-(Across * CS, i * CS)
Next i
End Sub
Sub WAIT(Tim As Integer)
Dim LastWait As Long
LastWait = GetTickCount
Do While Tim >
GetTickCount - LastWait
DoEvents
Loop
End Sub
4. Simpan, dan jalankan program. Tampilan yang didapatkan adalah sebagai berikut:
0 komentar:
Posting Komentar