Cara Membuat Game Dari Visual Basic PART 2

Ini ada satu lagi, mungkin ada sahabat-sahabat NNB pernah dengar iklan atau liat iklan yang bunyinya "Ingin Tau Persentase Hubungan Kamu Dengan Pacar Kamu", nah gara-gara iklan ini lah sehingga muncul ide buat game nya.

Tampilan Game nya


Cukup sederhana listingnya, dua jam bisa jadi, silahkan liat tutornya aja yah.

Object yang di butuhkan

1 Buah Form
Beri nama : Menu

2 Buah TextBox
Beri Nama : txtKamu, txtPacar

1 Buah Modul
Beri nama : mdlCinta

1 Buah CommandButton
Beri Nama : cmdHitung

3 Buah Label
Beri Nama : Label1, Label2, lblHitung

Listing Form [Menu]

Option Base 1
Dim i As Integer
Dim j As Integer
Dim nStep As Integer
Dim Cinta As String
Dim ChatWord As String
Dim WordStep As Integer
Dim nSecond As Integer
Private Sub Timer1_Timer()
Select Case nStepCase 0: WordStep = 0: nSecond = 0
ChatWord = "Assalamu Alaikum, Opa Jun-Qz sedang menghitung masa depan cintamu dengan si dia.": nStep = 1
Case 1: WordStep = WordStep + 1
If WordStep >= Len(ChatWord) Then nStep = 2: nSecond = 0
Case 2: nSecond = nSecond + 1: If nSecond > 2 Then nStep = 3: ChatWord = "1": Timer1.Interval = 10: nSecond = 0
Case 3
ChatWord = Val(ChatWord) + 1
If ChatWord >= 100 Then nStep = 4: nSecond = 0: ChatWord = "Selesai, WASSALAM !!"
Case 4
nSecond = nSecond + 1
If nSecond > 2 Then nStep = 5: ChatWord = "Jumlahnya adalah " & vbCrLf & Cinta & " %": WordStep = Len(ChatWord): Beep
Case 5: cmdHitung.Enabled = True: txtKamu.Locked = False: txtPacar.Locked = False
nStep = 0: Timer1.Interval = 100: Timer1.Enabled = False
End Select
lblHitung.Caption = Mid(ChatWord, 1, WordStep)
End Sub
Private Sub cmdHitung_Click()
On Error Resume Next
Dim WordType(8) As Integer
Dim CoupleName As String
Dim Amount As Integer
If Trim(txtKamu.Text) = "" Or Trim(txtPacar.Text) = "" Then
MsgBox "Isi nama kamu dan nama pacar kamu ? ", vbExclamation, "Informasi"
Exit Sub
End If
cmdHitung.Enabled = False: txtKamu.Locked = True
Timer1.Enabled = True: txtPacar.Locked = True
Amount = 8
CoupleName = txtKamu.Text + txtPacar.Text
DelSpace CoupleName
For j = 1 To UBound(WordType)
For i = 1 To Len(CoupleName)
If Mid(CoupleName, i, 1) = GetTextName(",A,I,U,E,0,", j) Or Mid(CoupleName, i, 1) = GetTextName(",a,i,u,e,o,", j) Then
WordType(j) = WordType(j) + 1
End If
Next iNext jDo While Amount > 2
For i = 1 To Amount - 1
WordType(i) = WordType(i) + WordType(i + 1)
If WordType(i) > 9 Then WordType(i) = WordType(i) - 10
Next iAmount = Amount - 1
Loop
Cinta = Str(WordType(1)) + Trim(Str(WordType(2)))
If Val(Cinta) < 10 Then Cinta = Trim(Mid(Cinta, 2, 1))
End Sub
Private Sub txtPacar_GotFocus()
txtPacar.SelStart = 0: txtPacar.SelLength = Len(txtPacar.Text)
End Sub
Private Sub txtKamu_GotFocus()
txtKamu.SelStart = 0: txtKamu.SelLength = Len(txtKamu.Text)
End Sub
Private Sub txtKamu_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
cmdHitung_ClickEnd If
End Sub
Private Sub txtPacar_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then cmdHitung_ClickEnd Sub

Listing Modul [mdlCinta]

Public Function GetTextName(TextValue As String, ObjectTarget As Integer, Optional OutputString As String) As String
Dim NowObject As Integer
Dim TextResult As String
Dim i As Integer
For i = 1 To Len(TextValue)
If Mid(TextValue, i, 1) = "," Then NowObject = NowObject + 1
If NowObject = ObjectTarget Then
If Mid(TextValue, i + 1, 1) <> "," Then TextResult = TextResult + Mid(TextValue, i + 1, 1)
ElseIf ObjectTarget < NowObject Then
OutputString = TextResult
GetTextName = TextResult
Exit For
End If
Next iEnd Function
Public Sub DelSpace(Txtstring As String)
Dim TempString As String
Dim i As Integer
For i = 1 To Len(Txtstring)
If Mid(Txtstring, i, 1) <> " " Then
TempString = TempString + Mid(Txtstring, i, 1)
End If
Next iTxtstring = TempString
End Sub

Credit by Jun-Qz N3

Artikel Terkait: