chapppter 5

Private Declare Function GetTickCount Lib "kernel32" () As Long 'this function lets us not use timer
'timers are bad :)

'main body... each part of the snake has X and Y
Private Type Part
X As Integer
Y As Integer
End Type

'Dynamic array to store part coordinates
Dim Part() As Part

'Velocity in X and Y direction of the snake
Dim vX As Integer, vY As Integer
Dim i As Integer 'for loops
Dim CS As Single 'cell size

Dim FX As Integer, FY As Integer 'food coordinates
Dim X As Integer, Y As Integer

Dim bRunning As Boolean, died As Boolean

Private Sub Form_Load()
Randomize 'random generation

'Initialize controls******************
Picture1.BackColor = vbWhite
Picture1.ScaleMode = 3 'pixels

CS = 20 'cell size in pixels
X = Int(Picture1.ScaleWidth / CS)
Y = Int(Picture1.ScaleHeight / CS)

Picture1.AutoRedraw = True
Picture1.ScaleWidth = X * CS
Picture1.ScaleHeight = Y * CS

Me.WindowState = 2
Me.Show

DrawGrid Picture1, CS
'*************************************

died = False
'set up the game
ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0

FX = Int(Rnd * X)
FY = Int(Rnd * Y)
'go to main loop
bRunning = True
MainLoop
End Sub

Sub MainLoop()
Do While bRunning = True
Update
Draw
WAIT (50) 'increasing this number makes game slower
Loop

Unload Me
End Sub

Sub Update()
'MOVE PARTS
For i = UBound(Part) To 1 Step -1
Part(i).X = Part(i - 1).X
Part(i).Y = Part(i - 1).Y
Next i

'MOVE HEAD
Part(0).X = Part(0).X + vX
Part(0).Y = Part(0).Y + vY

'HAS HE GONE OUT OF BOUNDS ?
If Part(0).X <>= X Or Part(0).Y <>= Y Then
died = True
End If

'HAS HE CRASHED INTO HIMSELF ?
For i = 1 To UBound(Part)
If Part(i).X = Part(0).X And Part(i).Y = Part(0).Y Then
died = True
End If
Next i

'DID HE EAT FOOD ?
If Part(0).X = FX And Part(0).Y = FY Then
ReDim Preserve Part(UBound(Part) + 1)
Part(UBound(Part)).X = -CS
Part(UBound(Part)).Y = -CS
FX = Int(Rnd * X)
FY = Int(Rnd * Y)

Form1.Caption = "Parts: " & UBound(Part)
End If

'IS HE DEAD ?
If died = True Then NewGame
End Sub

Sub Draw()
'DRAW WHITENESS
Rectangle 0, 0, X * CS, Y * CS, vbWhite
'DRAW SNAKE. PARTS IN BLUE, HEAD IN GREEN
For i = 1 To UBound(Part)
Rectangle Part(i).X * CS, Part(i).Y * CS, Part(i).X * CS + CS, Part(i).Y * CS + CS, vbBlue
Next i
Rectangle Part(0).X * CS, Part(0).Y * CS, Part(0).X * CS + CS, Part(0).Y * CS + CS, vbGreen
'DRAW FOOD
Rectangle FX * CS, FY * CS, FX * CS + CS, FY * CS + CS, vbRed

DrawGrid Picture1, CS
End Sub

Sub Rectangle(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, color As Long)
Picture1.Line (X1, Y1)-(X2, Y2), color, BF
End Sub

Sub NewGame()
'SET UP NEW GAME
died = False

ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0

vX = 0
vY = 0

FX = Int(Rnd * X)
FY = Int(Rnd * Y)
End Sub

Sub DrawGrid(Pic As Control, CS As Single)
'**************************************************************************
'DRAW GRID
'**************************************************************************
Dim i As Integer, Across As Single, Up As Single

Across = Pic.ScaleWidth / CS
Up = Pic.ScaleHeight / CS

For i = 0 To Across
Pic.Line (i * CS, 0)-(i * CS, Up * CS)
Next i

For i = 0 To Up
Pic.Line (0, i * CS)-(Across * CS, i * CS)
Next i
End Sub

Sub WAIT(Tim As Integer)
'**************************************************************************
'WAIT FUNCTION
'**************************************************************************
Dim LastWait As Long
LastWait = GetTickCount

Do While Tim > GetTickCount - LastWait
DoEvents
Loop
End Sub

Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
'USER KEYPRESSES HANDLED HERE
Select Case KeyCode
Case vbKeyRight
vX = 1
vY = 0
Case vbKeyLeft
vX = -1
vY = 0
Case vbKeyUp
vX = 0
vY = -1
Case vbKeyDown
vX = 0
vY = 1
End Select
End Sub

Private Sub Picture1_KeyPress(KeyAscii As Integer)
'27 is ESC. IF user presses ESC, QUIT
If KeyAscii = 27 Then bRunning = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
'This function can be left out
End
End Sub

chapppter 4

Option Explicit
Dim days As Long '<-Stores the number of days elapsed from 1/1/1900 to current month and year
Dim i As Integer

Private Sub cmdGenerate_Click()
On Error GoTo Error_handle 'On error, goto to end of function
days = 0
For i = 0 To 34
 Label1(i).Caption = "" 'Clear all the labels
Next i

For i = 1900 To txtYear.Text - 1
     If i Mod 4 = 0 Then 'If leap year then count 366 days
         days = days + 366
     Else            'else 365 days
         days = days + 365
     End If
Next i

For i = 1 To txtMonth.Text - 1
     If i = 1 Or i = 3 Or i = 5 Or i = 7 Or i = 8 Or i = 10 Or i = 12 Then 'For January,March,May....,December count 31 days
         days = days + 31
     ElseIf (i = 4 Or i = 6 Or i = 9 Or i = 11) Then 'For April,June,September,November count 30 days
         days = days + 30
     ElseIf (i = 2 And txtYear.Text Mod 4 = 0) Then 'If month is February and year is leap year count 29 days
         days = days + 29
     Else 'If month is February and year is not a leap year, count 28 days
         days = days + 28
     End If
Next i

 If (i = 1 Or i = 3 Or i = 5 Or i = 7 Or i = 8 Or i = 10 Or i = 12) Then
     show_calender 31 'Show calender with 31 days
 ElseIf (i = 4 Or i = 6 Or i = 9 Or i = 11) Then
     show_calender 30 'Show calender with 30 days
 ElseIf (i = 2 And txtYear.Text Mod 4 = 0) Then
     show_calender 29 'Show calender with 29 days
 Else
     show_calender 28 'Show calender with 28 days
 End If
Error_handle:
End Sub

Private Function show_calender(n As Integer) '//<- n stores the number of days to display
Dim i, k As Integer
k = days Mod 7 'Divide days with 7, the remainder give the current day
For i = 1 To n
 Label1(k).Caption = i 'Display the number in calender format
 k = k + 1
 If k = 35 Then k = 0
Next i
End Function

Private Sub txtMonth_Change()

End Sub

chapppter 3

Option Explicit

Private Hasil As Double
Private Const opNol = 0
Private Const opTambah = 1
Private Const opKurang = 2
Private Const opKali = 3
Private Const opBagi = 4
Private Operator As Integer
Private NilaiBaru As Boolean

' untuk menghapus karakter terakhir
Private Sub Hapus()
Dim txt As String
Dim min_len As Integer

txt = txtDisplay.Text
If Left$(txt, 1) = "-" Then
min_len =
2
Else
min_len =
1
End If


If Len(txt) > min_len Then
txtDisplay.Text = Left$(txt, Len(txt) - 1)
Else
txtDisplay.Text = "0"
End If
End Sub

' hapus angka, hasil terakhir dan operator

Private Sub cmdClear_Click()
cmdClearEntry_Click
Hasil = 0
Operator = opNol

End Sub

' hapus angka
Private Sub cmdClearEntry_Click()
txtDisplay.Text = ""
End Sub

' menambahkan koma (desimal)
Private Sub cmdKoma_Click()
If InStr(txtDisplay.Text, ".") Then
Beep
Else

If NilaiBaru Then
txtDisplay.Text = "."
"
NilaiBaru = False


Else
txtDisplay.Text = txtDisplay.Text & "."
End If
End If
End Sub

' Menghitung
Private Sub cmdSamaDengan_Click()
Dim HasilBaru As Double

If txtDisplay.Text = "" Then
HasilBaru = 0
Else

HasilBaru = CDbl(txtDisplay.Text)
End If
Select Case Operator


Case opNol
Hasil = HasilBaru
Case opTambah
Hasil = Hasil + HasilBaru
Case opKurang
Hasil = Hasil - HasilBaru
Case opKali


Hasil = Hasil * HasilBaru
Case opBagi
'Tidak bisa dibagi nol


If HasilBaru = 0 Then
MsgBox "Tidak bisa dibagi 0", vbOKOnly + vbCritical, "Kalku ERROR"
Call cmdClear_Click
Else
Hasil = Hasil / HasilBaru
End If

End Select
Operator = opNol
NilaiBaru = True
txtDisplay.Text = Format$(Hasil)


End Sub


' menuliskan angka
Private Sub cmdAngka_Click(Index As Integer)


If NilaiBaru Then
txtDisplay.Text = Format$(Index)
NilaiBaru = False


Else
txtDisplay.Text = _
txtDisplay.Text & Format$(Index)
End If
End Sub

' tombol tambah/kurang/bagi/kali
Private Sub cmdOperator_Click(Index As Integer)


cmdSamaDengan_Click

Operator = Index

NilaiBaru = True
End Sub

' merubah tanda +/-
Private Sub cmdPlusMinus_Click()
If NilaiBaru Then
txtDisplay.Text = "-"
ElseIf Left$(txtDisplay.Text, 1) = "-" Then
txtDisplay.Text = Right$(txtDisplay.Text, 2)
Else


Artikel Populer IlmuKomputer.Com
Copyright © 2005 IlmuKomputer.Com

txtDisplay.Text = "-" & txtDisplay.Text
End If
End Sub

' filter untuk angka saja yg dapat diketikkan
Private Sub Form_KeyPress(KeyAscii As Integer)
txtDisplay_KeyPress KeyAscii
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
txtDisplay_KeyUp KeyCode, Shift
End Sub

' supaya kursor tetap di kanan
Private Sub txtDisplay_Change()
txtDisplay.SelStart = Len(txtDisplay.Text)
End Sub

Private Sub txtDisplay_GotFocus()
txtDisplay_Change
End Sub

' untuk mengetikkan angka di keyboard
Private Sub txtDisplay_KeyPress(KeyAscii As Integer)
Dim ch As String

ch = Chr$(KeyAscii)
Select Case ch
Case "0"
cmdAngka_Click
0
Case "1"
cmdAngka_Click
1
Case "2"
cmdAngka_Click
2
Case "3"
cmdAngka_Click
3
Case "4"
cmdAngka_Click
4
Case "5"
cmdAngka_Click
5
Case "6"
cmdAngka_Click
6
Case "7"
cmdAngka_Click
7
Case "8"
cmdAngka_Click
8
Case "9"
cmdAngka_Click
9
Case "*", "x", "X"
cmdOperator_Click opKali
Case "+"
"
cmdOperator_Click opTambah
Case vbCrLf, vbCr, "="
"

cmdSamaDengan_Click
Case "-"
"
cmdOperator_Click opKurang
Case "."
"
cmdKoma_Click
Case "/"
"
cmdOperator_Click opBagi
Case "C", "c"
cmdClearEntry_Click
End Select


KeyAscii = 0
End Sub

' untuk ketikan angka di numpad
Private Sub txtDisplay_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyNumpad0
cmdAngka_Click 0
Case vbKeyNumpad1
cmdAngka_Click 1
Case vbKeyNumpad2
cmdAngka_Click 2
Case vbKeyNumpad3
cmdAngka_Click 3
Case vbKeyNumpad4
cmdAngka_Click 4
Case vbKeyNumpad5
cmdAngka_Click 5
Case vbKeyNumpad6
cmdAngka_Click 6
Case vbKeyNumpad7
cmdAngka_Click 7
Case vbKeyNumpad8
cmdAngka_Click 8
Case vbKeyNumpad9
cmdAngka_Click 9
Case vbKeyMultiply
cmdOperator_Click opKali
Case vbKeyAdd
cmdOperator_Click opTambah
Case vbKeySeparator
cmdSamaDengan_Click
Case vbKeySubtract
cmdOperator_Click opKurang
Case vbKeyDivide
cmdOperator_Click opBagi
Case vbKeyDecimal
cmdKoma_Click
Case vbKeyBack, vbKeyDelete

Hapus

End Select

KeyCode = 0
End Sub


Private Sub Text1_Change()

End Sub

chapppter 2

chapppter 1