nih gw kluarin smua game

Akhirnya game ini selesai juga, selama 2 hari berteman dengan VB6 hasilnya lumayan juga, nich buat yang mau belajar buat game sendiri, gue bantu kasih tutorialnya, lumayan sebagai pengisi waktu.

Tampilan Game Sebelum Mulai
[You must be registered and logged in to see this image.]


Nich Tutornya...

Object yang di butuhkan

1 Buah Form
Beri nama : Main

1 Buah Timer
Beri nama : Timer2
Ubah Interval Timer = 1000

1 Buah Modul
Beri nama : Module1

Listing Form [Main]

Dim a$
Dim c As Integer

Private Sub Command1_Click()
Command1.Enabled = False
life = 5
Stage = 0
Call Backgroundmusic
Call main_routine
End Sub

Sub sound()
sndPlaySound App.Path & "\pick.wav", SND_ASYNC
End Sub

Sub check_border()
If xpos < 0 Then xpos = 0
If (xpos + TILEWIDTH) > AREAWIDTH Then xpos = AREAWIDTH - TILEWIDTH
If ypos < 0 Then ypos = 0
If (ypos + TILEHEIGHT) > AREAHEIGHT Then ypos = AREAHEIGHT - TILEHEIGHT
End Sub

Sub check_keyboard()
If GetKeyState(vbKeyUp) And KEY_DOWN Then ypos = ypos - YOFFSET: direction = DUP
If GetKeyState(vbKeyDown) And KEY_DOWN Then ypos = ypos + YOFFSET: direction = DDOWN
If GetKeyState(vbKeyLeft) And KEY_DOWN Then xpos = xpos - XOFFSET: direction = DLEFT
If GetKeyState(vbKeyRight) And KEY_DOWN Then xpos = xpos + XOFFSET: direction = DRIGHT
Call check_border
If GetKeyState(vbKeyQ) And KEY_DOWN Then gameover = True
End Sub

Sub display()
frame_time = frame_time + 1
If frame_time > WAITFRAME And frame_time <= WAITFRAME * 2 Then
frame = 1
Else:
If frame_time > WAITFRAME * 2 Then
frame_time = 0
frame = 0
End If
End If
BitBlt Main_Pic.hDC, xpos, ypos, TILEWIDTH, TILEHEIGHT, Pic.hDC, (frame * TILEWIDTH) + (2 * TILEWIDTH), direction * TILEHEIGHT, vbSrcAnd
BitBlt Main_Pic.hDC, xpos, ypos, TILEWIDTH, TILEHEIGHT, Pic.hDC, (frame * TILEWIDTH), direction * TILEHEIGHT, vbSrcPaint
End Sub

Sub first_data()
xpos = 10 * TILEWIDTH
ypos = 8 * TILEHEIGHT
treasure = MAXTREASURE
flower = MAXFLOWER
End Sub

Sub main_routine()
Do
delay (20)
Call check_keyboard
Main_Pic.Cls
Call display_background
Call display
Call check_grid
Call move_enemy
Main_Pic.Refresh
display_status
Call ServiceBackgroundMusic("BGM")
Loop Until gameover = True
Call CloseTRM
End
End Sub

Sub check_grid()
Dim col As Integer, row As Integer
Dim centerx As Integer, centery As Integer
Dim i As Integer, j As Integer
centerx = xpos + (TILEWIDTH / 2)
centery = ypos + (TILEHEIGHT / 2)
col = Int(centerx / TILEWIDTH)
row = Int(centery / TILEHEIGHT)
Select Case grid(col, row)
Case 1
MsgBox "Kamu berhasil selesaikan level ini", vbinfo, "Selamat"
Stage = Stage + 1
If Stage > (MAXSTAGE - 1) Then
MsgBox "Tammat Deh!", vbinfo, "Tammat"
gameover = True
Else:
Call initialize_game
End If
Case 2
grid(col, row) = 0
Call death
Case 3
grid(col, row) = 0
Call sound
treasure = treasure - 1
score = score + 100
If treasure = 0 Then
Do
Randomize Timer
col = Int(Rnd * MAXCOL)
row = Int(Rnd * MAXROW)
If (col <> 10 And row <> And grid(col, row) = 0 Then
grid(col, row) = 1
Exit Do
End If
Loop
End If
Case 4
Call sound
score = score + 100
grid(col, row) = 0
flower = flower - 1
If flower = 0 Then
Do
Randomize Timer
i = Int(Rnd * (MAXCOL - 1))
j = Int(Rnd * (MAXROW - 1))
If grid(i, j) = 0 Then
grid(i, j) = 5
Exit Do
End If
Loop
End If
Case 5
life = life + 1
score = score + 1000
grid(col, row) = 0
End Select
End Sub

Sub move_enemy()
Dim i As Integer
Dim direction As Integer
For i = 0 To (MAXENEMY - 1)
Select Case i
Case 0
If enemy(i).x < xpos Then
enemy(i).x = enemy(i).x + ENEMYSPEED
direction = DRIGHT
Else:
enemy(i).x = enemy(i).x - ENEMYSPEED
direction = DLEFT
End If
If enemy(i).y < ypos Then
enemy(i).y = enemy(i).y + ENEMYSPEED
direction = DDOWN
Else:
enemy(i).y = enemy(i).y - ENEMYSPEED
direction = DUP
End If
Case 1
If enemy(i).x < xpos Then
enemy(i).x = enemy(i).x + ENEMYSPEED
direction = DRIGHT
Else:
enemy(i).x = enemy(i).x - ENEMYSPEED
direction = DLEFT
End If
Case 2
If enemy(i).y < ypos Then
enemy(i).y = enemy(i).y + ENEMYSPEED
direction = DDOWN
Else:
enemy(i).y = enemy(i).y - ENEMYSPEED
direction = DUP
End If
End Select
BitBlt Main_Pic.hDC, enemy(i).x, enemy(i).y, TILEWIDTH, TILEHEIGHT, Enemy_pic.hDC, (frame * TILEWIDTH) + (TILEWIDTH * 2), direction * TILEHEIGHT, vbSrcAnd
BitBlt Main_Pic.hDC, enemy(i).x, enemy(i).y, TILEWIDTH, TILEHEIGHT, Enemy_pic.hDC, frame * TILEWIDTH, direction * TILEHEIGHT, vbSrcPaint
Call check_enemy(i)
Next i
End Sub

Sub check_enemy(i As Integer)
Dim j As Integer
If enemy(i).x < (xpos + TILEWIDTH - 5) And (enemy(i).x + TILEWIDTH) > xpos + 5 Then
If enemy(i).y < (ypos + TILEHEIGHT - 5) And (enemy(i).y + TILEHEIGHT) > ypos + 5 Then
Call death
End If
End If
End Sub

Sub death()
Dim j, k As Integer
For j = 1 To 5
For k = 0 To 3
Main_Pic.Cls
Call display_background
BitBlt Main_Pic.hDC, xpos, ypos, TILEWIDTH, TILEHEIGHT, Pic.hDC, (frame * TILEWIDTH) + (2 * TILEWIDTH), k * TILEHEIGHT, vbSrcAnd
BitBlt Main_Pic.hDC, xpos, ypos, TILEWIDTH, TILEHEIGHT, Pic.hDC, (frame * TILEWIDTH), k * TILEHEIGHT, vbSrcPaint
Main_Pic.Refresh
delay (100)
Next k
Next j
xpos = 10 * TILEWIDTH
ypos = 8 * TILEHEIGHT
life = life - 1
If life = 0 Then
MsgBox "Yah Mati Deh!", vbCritical, "Game Over"
gameover = True
End If
Call make_enemy
End Sub

Sub make_enemy()
Dim i As Integer
For i = 0 To (MAXENEMY - 1)
Randomize Timer
Select Case i
Case 0
enemy(i).x = 0
enemy(i).y = 0
Case 1
enemy(i).y = (Int(Rnd * (MAXROW - 1))) * TILEHEIGHT
enemy(i).x = 0
Case 2
enemy(i).x = (Int(Rnd * (MAXCOL - 1))) * TILEWIDTH
enemy(i).y = 0
End Select
Next i
End Sub

Sub display_background()
Dim col As Integer, row As Integer
For row = 0 To (MAXROW - 1)
For col = 0 To (MAXCOL - 1)
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Floor_Pic.hDC, Stage * TILEWIDTH, 0, vbSrcCopy
Select Case grid(col, row)
Case 1
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Obj_Pic.hDC, grid(col, row) * TILEWIDTH, 0, vbSrcCopy
Case 2, 3
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Obj_Pic.hDC, grid(col, row) * TILEWIDTH, TILEHEIGHT, vbSrcAnd
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Obj_Pic.hDC, grid(col, row) * TILEWIDTH, 0, vbSrcPaint
Case 4
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Floor_Pic.hDC, Stage * TILEWIDTH, TILEHEIGHT, vbSrcCopy
Case 5
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Princess_pic.hDC, (frame * TILEWIDTH) + (TILEWIDTH * 2), 0, vbSrcAnd
BitBlt Main_Pic.hDC, col * TILEWIDTH, row * TILEHEIGHT, TILEWIDTH, TILEHEIGHT, Princess_pic.hDC, frame * TILEWIDTH, 0, vbSrcPaint
End Select
Next col
Next row
End Sub

Private Sub Form_Load()
a$ = "forum sebelah Indonesia Cyber Comunity"
Pic.Picture = LoadPicture(App.Path & "\jun-qz.gif")
Princess_pic.Picture = LoadPicture(App.Path & "\princess.gif")
Enemy_pic.Picture = LoadPicture(App.Path & "\enemy.gif")
Obj_Pic.Picture = LoadPicture(App.Path & "\Object.gif")
Floor_Pic.Picture = LoadPicture(App.Path & "\Floor.gif")
initialize_game
End Sub

Sub display_status()
Score_lbl.Caption = score: Score_lbl.Refresh
Life_lbl.Caption = life: Life_lbl.Refresh
Treasure_lbl.Caption = treasure: Treasure_lbl.Refresh
Flower_lbl.Caption = flower: Flower_lbl.Refresh
End Sub

Sub initialize_game()
Dim col As Integer, row As Integer
Dim i As Integer
For row = 0 To (MAXROW - 1)
For col = 0 To (MAXCOL - 1)
grid(col, row) = 0
Next col
Next row
For i = 1 To MAXFLOWER
Do
Randomize Timer
col = Int(Rnd * MAXCOL)
row = Int(Rnd * MAXROW)
If (col <> 10 And row <> And (grid(col, row) = 0) Then
grid(col, row) = 4
Exit Do
End If
Loop
Next i
For i = 1 To MAXTREASURE
Do
Randomize Timer
col = Int(Rnd * MAXCOL)
row = Int(Rnd * MAXROW)
If (col <> 10 And row <> And (grid(col, row) = 0) Then
grid(col, row) = 3
Exit Do
End If
Loop
Next i
For i = 1 To MAXDRAGON
Do
Randomize Timer
col = Int(Rnd * MAXCOL)
row = Int(Rnd * MAXROW)
If (col <> 10 And row <> And (grid(col, row) = 0) Then
grid(col, row) = 2
Exit Do
End If
Loop
Next i
Call first_data
Call make_enemy
End Sub

Private Sub Form_Unload(Cancel As Integer)
CloseTRM
End
End Sub

Private Sub Timer2_Timer()
ServiceBackgroundMusic "TRM"
End Sub

Listing Modul [Module1]

Global Const TILEWIDTH = 32, TILEHEIGHT = 32
Global Const AREAWIDTH = 640, AREAHEIGHT = 480
Global Const MAXCOL = AREAWIDTH / TILEWIDTH, MAXROW = AREAHEIGHT / TILEHEIGHT
Global Const MAXENEMY = 3
Global Const MAXTREASURE = 50
Global Const MAXDRAGON = 50
Global Const SND_ASYNC = &H1, SND_NOSTOP = &H10
Global Const KEY_DOWN As Integer = &H1000
Global Const DUP = 0, DRIGHT = 1, DDOWN = 2, DLEFT = 3
Global Const WAITFRAME = 20
Global Const XOFFSET = 3, YOFFSET = 3
Global Const ENEMYSPEED = 1
Global Const MAXFLOWER = 20
Global Const MAXSTAGE = 9
Type enemyproperties
x As Integer
y As Integer
End Type
Global grid(MAXCOL - 1, MAXROW - 1) As Integer
Global xpos As Integer, ypos As Integer
Global enemy(MAXENEMY - 1) As enemyproperties
Global treasure As Integer, flower As Integer
Global score As Single, life As Integer
Global frame_time As Integer, frame As Integer
Global gameover As Boolean
Global direction As Integer
Global Stage As Integer
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
Sub delay(wait As Long)
Dim lasttick As Long
Dim currenttick As Long
lasttick = GetTickCount
Do
currenttick = GetTickCount
DoEvents
Loop Until ((currenttick - lasttick) > wait)
End Sub

Sub ServiceBackgroundMusic(Identifier As String)
Dim rt As Long
Dim Status As String
Status = " "
rt = mciSendString("STATUS " & Identifier & " MODE", Status, Len(Status), 0)
If rt = 0 Then
Status = Trim$(Status)
If Left(UCase$(Status), Len("STOPPED")) = "STOPPED" Then
mciSendString "PLAY " & Identifier & " FROM 0", "", 0, 0
End If
End If
End Sub

Sub Backgroundmusic()
mciSendString "open TRM.wav alias TRM", 0&, 0, 0
mciSendString "play TRM from 0", 0&, 0, 0
End Sub

Sub CloseTRM()
mciSendString "stop TRM", 0&, 0, 0
mciSendString "close TRM", 0&, 0, 0
End Sub
Download sorce code & sample nya disini

Credit by Jun-Qz N3