kali ini dilanjutkan dengan penambahan module dan prosedur untuk fungsi jatuh,musik,menabrak,danlain lain
Untuk itu, pertama buka file yang sudah sesuai dengan part I nya.
jangan lupa import dulu file tambahan berupa transparansi gambar.
2. buatlah modul, dengan nama seperti screenschoot gambar di bawah ini
Buat lah 3 File Modules
1. FuncMod
2. ModPicBuddy
3. ModSound
Pastekan Script Untuk FuncMod
Public started As Boolean
Public allHeight As Long
Public pipeHDistance As Long
Public pipeVDistance As Long
Public speed As Long
Public gameover As Boolean
Public entered As Boolean
Public scored1, scored4 As Boolean
Public Function CheckIfGameOver() As Boolean
CheckIfGameOver = False
Dim a, b, c, d, a1, b1, c1, d1 As Integer
With frmMain
a = .imgBird.Top
b = .imgBird.Left
c = b + .imgBird.Width
d = a + .imgBird.Height
If (Not gameover) Then
a1 = .Image2.Top
b1 = .Image2.Left
c1 = b1 + .Image2.Width
d1 = a1 + .Image2.Height
If a <= d1 And (c >= b1 And b <= c1) Then
Gameovered
End If
End If
If (Not gameover) Then
a1 = .Image3.Top
b1 = .Image3.Left
c1 = b1 + .Image3.Width
d1 = a1 + .Image3.Height
If a <= d1 And (c >= b1 And b <= c1) Then
Gameovered
End If
End If
If (Not gameover) Then
a1 = .Image1.Top
b1 = .Image1.Left
c1 = b1 + .Image1.Width
d1 = a1 + .Image1.Height
If d >= a1 And (c >= b1 And b <= c1) Then
Gameovered
End If
End If
If (Not gameover) Then
a1 = .Image4.Top
b1 = .Image4.Left
c1 = b1 + .Image4.Width
d1 = a1 + .Image4.Height
If d >= a1 And (c >= b1 And b <= c1) Then
Gameovered
End If
End If
End With
CheckIfGameOver = gameover
End Function
Public Sub NewGame()
frmMain.Timer1.Interval = 100
gameover = False
entered = False
started = False
scored1 = False
scored4 = True
frmMain.imgBird.Left = 1680
frmMain.imgBird.Top = 1800
frmMain.imgBird.Picture = LoadPicture(App.Path & "\img\bird.gif")
frmMain.Command1.Left = 4680
frmMain.Command1.Caption = "Flap"
frmMain.Command2.Enabled = True
frmMain.Image1.Top = 2760
frmMain.Image1.Left = 4680
frmMain.Image1.Height = 1455
frmMain.Image2.Top = 0
frmMain.Image2.Left = 4680
frmMain.Image2.Height = 1335
frmMain.Image3.Top = 0
frmMain.Image3.Left = 8108
frmMain.Image3.Height = 1695
frmMain.Image4.Top = 3120
frmMain.Image4.Left = 8108
frmMain.Image4.Height = 1215
frmMain.Label1.Caption = "0"
End Sub
Public Sub Gameovered()
With frmMain
.imgBird.Picture = LoadPicture(App.Path & "\img\bird-dead.gif")
If Not .imgBird.Top >= 3600 Then
.tmrMove.Enabled = False
.Command1.Enabled = False
.Timer1.Enabled = False
.Timer1.Interval = 20
.Timer1.Enabled = True
Else
.Timer1.Enabled = False
End If
PlaySound App.Path & "\img\gameover.wav", 0, SND_FILENAME Or SND_ASYNC
.Command1.Caption = "New Game"
.Command1.Enabled = True
.Command1.Left = 1200
.Command2.Enabled = False
gameover = True
.tmrMove.Enabled = False
End With
End Sub
Dan Modules ModPicBuddy
Option Explicit
'From : www.rakaadinugroho.blogspot.com
'admin : Raka Adi Nugroho
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function SetWindowOrgEx Lib "gdi32.dll" (ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT, ByVal bErase As Long) As Long
Private Const NULL_BRUSH As Long = 5
Private Const NEWTRANSPARENT As Long = 3
Private Const WM_CTLCOLORSTATIC As Long = &H138
Private Const WM_PAINT As Long = &HF&
Private Const WM_ERASEBKGND As Long = &H14
Private Const WM_ENABLE As Long = &HA
Private Const WM_PRINTCLIENT As Long = &H318
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function comctl32DllGetVersion Lib "comctl32" Alias "DllGetVersion" (pdvi As DLLVERSIONINFO) As Long
Private Declare Function IsAppThemed Lib "uxtheme.dll" () As Long
Private Declare Function IsThemeActive Lib "uxtheme.dll" () As Long
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Const WM_THEMECHANGD As Long = &H31A&
Private Type DLLVERSIONINFO
cbSize As Long
dwMajor As Long
dwMinor As Long
dwBuildNumber As Long
dwPlatformID As Long
End Type
Private m_Themed As Boolean
Public Function ValidateThemeEmployed() As Boolean
'untuk determinan file
Dim lVersionInfo As Long, hMod As Long, fa As Long
Dim tdVI As DLLVERSIONINFO
lVersionInfo = GetVersion()
Select Case (lVersionInfo And &HFF)
Case 6&
m_Themed = True
Case 5&
m_Themed = ((lVersionInfo And &HFF00&) \ &H100 > 0&)
' jika minor
Case Else
m_Themed = False
End Select
If m_Themed Then
m_Themed = False
If IsThemeActive() Then
If IsAppThemed() Then
hMod = LoadLibrary("comctl32.dll")
If hMod Then
fa = GetProcAddress(hMod, "DllGetVersion")
If fa Then
tdVI.cbSize = Len(tdVI)
fa = comctl32DllGetVersion(tdVI)
If fa = 0& Then
m_Themed = (tdVI.dwMajor > 5&)
End If
End If
FreeLibrary hMod
End If
End If
End If
End If
ValidateThemeEmployed = m_Themed
End Function
Public Function picBuddyWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lProc As Long
lProc = GetProp(hwnd, "WndProc")
Select Case uMsg
Case WM_CTLCOLORSTATIC 'perintah message
If GetProp(lParam, "WndProc") Then
Dim vPT As POINTAPI
CallWindowProc lProc, hwnd, uMsg, wParam, lParam
If GetProp(lParam, "EraseBkg") = 1& Or m_Themed = True Then
SetProp lParam, "EraseBkg", 0
ClientToScreen lParam, vPT
ScreenToClient hwnd, vPT
SetWindowOrgEx wParam, vPT.X, vPT.Y, vPT
SendMessage hwnd, WM_PAINT, wParam, ByVal 0&
SetWindowOrgEx wParam, vPT.X, vPT.Y, vPT
End If
lProc = 0& ' jangan hilangkan kode ini
SetBkMode wParam, NEWTRANSPARENT
picBuddyWindowProc = GetStockObject(NULL_BRUSH)
End If
Case WM_ERASEBKGND
If m_Themed = False Then
If GetProp(hwnd, "ChildBtn") Then SetProp hwnd, "EraseBkg", 1&
End If
Case WM_THEMECHANGD
If GetProp(hwnd, "ChildBtn") = 0& Then ValidateThemeEmployed
Case WM_ENABLE
If GetProp(hwnd, "ChildBtn") Then
Dim wRect As RECT, iPt As POINTAPI
picBuddyWindowProc = CallWindowProc(lProc, hwnd, uMsg, wParam, lParam)
GetClientRect hwnd, wRect
InvalidateRect hwnd, wRect, True
lProc = 0&
End If
End Select
If lProc Then picBuddyWindowProc = CallWindowProc(lProc, hwnd, uMsg, wParam, lParam)
End Function
dan yang terakhir Mod Sound
Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
(ByVal lpszName As String, _
ByVal hModule As Long, _
ByVal dwFlags As Long) As Long
Private Const SND_APPLICATION As Long = &H80
Private Const SND_ALIAS As Long = &H10000
Private Const SND_ALIAS_ID As Long = &H110000
Private Const SND_ASYNC As Long = &H1
Private Const SND_FILENAME As Long = &H20000
Private Const SND_LOOP As Long = &H8
Private Const SND_MEMORY As Long = &H4
Private Const SND_NODEFAULT As Long = &H2
Private Const SND_NOSTOP As Long = &H10
Private Const SND_NOWAIT As Long = &H2000
Private Const SND_PURGE As Long = &H40
Private Const SND_RESOURCE As Long = &H40004
Private Const SND_SYNC As Long = &H0
(ByVal lpszName As String, _
ByVal hModule As Long, _
ByVal dwFlags As Long) As Long
Private Const SND_APPLICATION As Long = &H80
Private Const SND_ALIAS As Long = &H10000
Private Const SND_ALIAS_ID As Long = &H110000
Private Const SND_ASYNC As Long = &H1
Private Const SND_FILENAME As Long = &H20000
Private Const SND_LOOP As Long = &H8
Private Const SND_MEMORY As Long = &H4
Private Const SND_NODEFAULT As Long = &H2
Private Const SND_NOSTOP As Long = &H10
Private Const SND_NOWAIT As Long = &H2000
Private Const SND_PURGE As Long = &H40
Private Const SND_RESOURCE As Long = &H40004
Private Const SND_SYNC As Long = &H0
Jadilah Game FlappyBird Versi Anda.
Keep Koding
Update Contact :
No Wa/Telepon (puat) : 085267792168
No Wa/Telepon (fajar) : 085369237896
Email : Fajarudinsidik@gmail.com
No Wa/Telepon (puat) : 085267792168
No Wa/Telepon (fajar) : 085369237896
Email: Fajarudinsidik@gmail.com
atau Kirimkan Private messanger melalui email dengan klik tombol order dibawah ini :
