Menggerakan Objek dengan Event Keyboard tanda panah di vb6 - Tentu kalian pernah bermain game, baik itu game online maupun offline.Banyak macam-macam game salah satu diantaranya adalah game jenis tetris menyusun balok,game jenis ini tidak asing lagi dikalangan gamer baik anak-anak ataupun dewasa karena permainan ini sangat mudah dimainkan,dimana kita tinggal menyusun balok tersebut dengan menggerakan beberapa tombol anak panah.
Pada pertemuan kali ini Saya ingin memberikan trik bagaimana menggerakan suatu objek dengan tombol keyboard tanda panah layaknya seperti game tetris menyusun balok.
Didalam trik ini Saya hanya memberikan simulasi saja yang cara kerjanya mirip game penyusun balok, dimana kita tinggal menekan tombol anak panah pada keyboard untuk menggerakannya baik kesamping,kebawah,keatas.Untuk lebih jelasnya perhatikan Screenshoot dibawah ini :
Untuk membuat gerakan suatu objek dengan tombol keyboard anak panah menurut Saya gampang-gampang susah.Gampang dalam artian kita tidak perlu menanamkan objek tertentu di dalam form tersebut dan dibiarkan kosong begitu saja dikatakan susah atau sulit karena kita memerlukan kode
yang membuat kita agak kesulitan untuk mendeskripsikannya karena memang sangat panjang.
Bagi Anda yang penesaran bagaimana membuatnya,sekarang langsung saja buka form standar visual basic 6 Anda dan beri Form dengan backcolor, Fillcolor dan Forecolor masing-masing semuanya warna hitam
Setelah diberikan background hitam saatnya kita akan memberikan kode di jendela kode.Copy-paste kode dibawah ini di bagian General-Declarations :
Option Explicit
'The "RECT" type required by the IntersectRect API call
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Our API calls
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Const MS_DELAY = 25 'Milliseconds each frame
Const RADIUS1 = 30 'Radius of our first circle
Const RADIUS2 = 20 'Radius of our second circle
Const RECT_WIDTH = 80 'Width of our rectangles
Const RECT_HEIGHT = 60 'Height of our rectangles
Dim msngCircle1X As Single 'Current X coordinate of the 1st circle
Dim msngCircle1Y As Single 'Current Y coordinate of the 1st circle
Dim msngCircle2X As Single 'Current X coordinate of the 2nd circle
Dim msngCircle2Y As Single 'Current Y coordinate of the 2nd circle
Dim mudtRect1 As RECT 'Our first rectangle
Dim mudtRect2 As RECT 'Our second rectangle
Dim mblnCircles As Boolean 'Are we displaying the circles...
Dim mblnRects As Boolean '...or the rectangles?
Dim mblnCollision As Boolean 'Is there a collision?
Dim mlngTimer As Long 'Holds system time since last frame was displayed
Dim mblnRunning As Boolean 'Is the render loop running?
Dim mblnLeftKey As Boolean 'Is the left arrow-key depressed?
Dim mblnRightKey As Boolean 'Is the right arrow-key depressed?
Dim mblnDownKey As Boolean 'Is the down arrow-key depressed?
Dim mblnUpKey As Boolean 'Is the up arrow-key depressed?
Private Sub Form_Load()
'Randomize the locations (just for fun)
Randomize
msngCircle1X = (Rnd() * frmMain.ScaleWidth / 2) + frmMain.ScaleWidth / 4
msngCircle1Y = (Rnd() * frmMain.ScaleHeight / 2) + frmMain.ScaleHeight / 4
msngCircle2X = (Rnd() * frmMain.ScaleWidth / 2) + frmMain.ScaleWidth / 4
msngCircle2Y = (Rnd() * frmMain.ScaleHeight / 2) + frmMain.ScaleHeight / 4
With mudtRect1
.Top = (Rnd() * frmMain.ScaleHeight / 2) + frmMain.ScaleHeight / 4
.Left = (Rnd() * frmMain.ScaleWidth / 2) + frmMain.ScaleWidth / 4
.Bottom = .Top + RECT_HEIGHT
.Right = .Left + RECT_WIDTH
End With
With mudtRect2
.Top = (Rnd() * frmMain.ScaleHeight / 2) + frmMain.ScaleHeight / 4
.Left = (Rnd() * frmMain.ScaleWidth / 2) + frmMain.ScaleWidth / 4
.Bottom = .Top + RECT_HEIGHT
.Right = .Left + RECT_WIDTH
End With
'Display the rectangles first
mblnRects = True
'Show the form
Me.Show
'Start the render loop
mblnRunning = True
Do While mblnRunning
'Check if we've waited for the appropriate number of milliseconds
If mlngTimer + MS_DELAY <= GetTickCount() Then
'Reset the timer
mlngTimer = GetTickCount()
'Clear the form
frmMain.Cls
'Display the circles...
If mblnCircles Then
'Check for collision
CircleCollision
'Move the circle
MoveCircle
'Display the circles
DrawCircle msngCircle1X, msngCircle1Y, RADIUS1, vbWhite
'Display RED if there is a collision
If mblnCollision Then
DrawCircle msngCircle2X, msngCircle2Y, RADIUS2, vbRed
Else
DrawCircle msngCircle2X, msngCircle2Y, RADIUS2, vbWhite
End If
'Display the rectangles...
ElseIf mblnRects Then
'Check for collision
RectCollision
'Move the rectangle
MoveRect
'Display the rectangles
DrawRect mudtRect1, vbWhite
'Display RED if there is a collision
If mblnCollision Then
DrawRect mudtRect2, vbRed
Else
DrawRect mudtRect2, vbWhite
End If
End If
End If
'Let windows do some stuff...
DoEvents
Loop
End Sub
Private Sub MoveCircle()
'Move the circle around...
If mblnDownKey = True Then msngCircle1Y = msngCircle1Y + 1
If mblnUpKey = True Then msngCircle1Y = msngCircle1Y - 1
If mblnLeftKey = True Then msngCircle1X = msngCircle1X - 1
If mblnRightKey = True Then msngCircle1X = msngCircle1X + 1
End Sub
Private Sub MoveRect()
'Move the rectangle around
With mudtRect1
If mblnDownKey = True Then
.Top = .Top + 1
.Bottom = .Bottom + 1
End If
If mblnUpKey = True Then
.Top = .Top - 1
.Bottom = .Bottom - 1
End If
If mblnLeftKey = True Then
.Left = .Left - 1
.Right = .Right - 1
End If
If mblnRightKey = True Then
.Left = .Left + 1
.Right = .Right + 1
End If
End With
End Sub
Private Sub CircleCollision()
'Check for circle collision
mblnCollision = GetDist(msngCircle1X, msngCircle1Y, msngCircle2X, msngCircle2Y) <= RADIUS1 + RADIUS2
End Sub
Private Sub RectCollision()
Dim udtTempRect As RECT 'The IntersectRect call will return a rectangle equal in size to the intersection between our two rectangles... but we don't really need this data here
'Check for rectangle collision
mblnCollision = IntersectRect(udtTempRect, mudtRect1, mudtRect2)
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'Check for keypresses
If KeyCode = vbKeyLeft Then mblnLeftKey = True
If KeyCode = vbKeyRight Then mblnRightKey = True
If KeyCode = vbKeyUp Then mblnUpKey = True
If KeyCode = vbKeyDown Then mblnDownKey = True
'If the user presses enter, switch between circles and rects
If KeyCode = vbKeyReturn Then
mblnCircles = Not (mblnCircles)
mblnRects = Not (mblnRects)
End If
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
'Check for keyreleases
If KeyCode = vbKeyLeft Then mblnLeftKey = False
If KeyCode = vbKeyRight Then mblnRightKey = False
If KeyCode = vbKeyUp Then mblnUpKey = False
If KeyCode = vbKeyDown Then mblnDownKey = False
End Sub
Private Sub DrawRect(rectSource As RECT, lngColour As Long)
'Draw the given rectangle
Line (rectSource.Left, rectSource.Top)-(rectSource.Left, rectSource.Bottom), lngColour
Line (rectSource.Left, rectSource.Top)-(rectSource.Right, rectSource.Top), lngColour
Line (rectSource.Right, rectSource.Bottom)-(rectSource.Right, rectSource.Top), lngColour
Line (rectSource.Right, rectSource.Bottom)-(rectSource.Left, rectSource.Bottom), lngColour
End Sub
Private Sub DrawCircle(sngX As Single, sngY As Single, sngRadius As Single, lngColour As Long)
'Draw the given circle
Circle (sngX, sngY), sngRadius, lngColour
End Sub
Private Function GetDist(intX1 As Single, intY1 As Single, intX2 As Single, intY2 As Single) As Single
'Return the distance between the two points (I love you, Mr. Pythagoras)
GetDist = Sqr((intX1 - intX2) ^ 2 + (intY1 - intY2) ^ 2)
End Function
Private Sub Form_Unload(Cancel As Integer)
'Terminate the render loop
mblnRunning = False
End Sub
Setelah Anda membuat kodenya sekarang simpan hasil pekerjaan Anda dan jalankan program.
Setelah berhasil dijalankan sekarang gerakan objek dengan menekan tombol tanda panah atas-bawah-kanan-kiri dengan begitu objek akan bergerak mengikutinya.Untuk merubah bentuk objek tekan Entar
Demikian trik dari Saya semoga bermanfaat dan menambah wawasan kita.Selamat mencoba semoga berhasil.
No comments:
Post a Comment