Tutorial Cara membuat Ramalan Cinta With Visual Basic

Ini ada satu lagi, mungkin ada sahabat-sahabat N3 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.

Spoiler Tutorial

 

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 nStep
Case 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 i
Next j
Do 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 i
Amount = 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_Click
End If
End Sub
Private Sub txtPacar_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then cmdHitung_Click
End 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 i
End 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 i
Txtstring = TempString
End Sub

Download sorce code & sample nya juga disini

Credit by Jun-Qz N3