'Types
Private Type tKeyTable
KeyUp As Long
KeyDown As Long
End Type
Private Type tCamera
'Size
w As Long
h As Long
'General
DC As Long
End Type
Private Type tObject
'Size
X As Single
Y As Single
'Start position
w As Long
h As Long
'Movement
SpeedX As Single
SpeedY As Single
'General
IsBall As Boolean
Color As Long
End Type
Private Type tPlayer
'General
Name As String
Score As Long
'Internal
KeyTable As tKeyTable
Pad As tObject
End Type
'Declares
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'Variables
'Internal
Dim Active As Boolean
Dim MaxFPS As Long
Dim KD() As Boolean
Dim Camera As tCamera
'Game objects
Dim PlayerCount As Long
Dim Player() As tPlayer
Dim BallCount As Long
Dim Ball() As tObject
Dim PadSpeed As Long
Dim PadAcceleration As Single
Dim BallSpeed As Long
Dim BallAcceleration As Single
Dim Friction As Single
Private Sub CheckKeys()
Dim A As Long
If KD(vbKeyEscape) Then: Unload Me
For A = 0 To PlayerCount
With Player(A)
If KD(.KeyTable.KeyUp) Then
'Key press up
.Pad.SpeedY = .Pad.SpeedY - PadAcceleration
If .Pad.SpeedY < -PadSpeed Then: .Pad.SpeedY = -PadSpeed
End If
If KD(.KeyTable.KeyDown) Then
'Key press down
.Pad.SpeedY = .Pad.SpeedY + PadAcceleration
If .Pad.SpeedY > PadSpeed Then: .Pad.SpeedY = PadSpeed
End If
If Not (KD(.KeyTable.KeyUp) Or KD(.KeyTable.KeyDown)) Then
'No keys
.Pad.SpeedY = .Pad.SpeedY * Friction
If Abs(.Pad.SpeedY) < Friction Then: .Pad.SpeedY = 0
End If
End With
Next
End Sub
Private Sub DrawObject(iObject As tObject)
'Draw object rect
With iObject
Me.FillColor = .Color
Me.ForeColor = .Color
Rectangle Camera.DC, .X, .Y, (.X + .w), (.Y + .h)
End With
End Sub
Private Sub DrawScore()
Dim A As Long
For A = 0 To PlayerCount
With Me
'Text position
.CurrentX = Player(A).Pad.X
.CurrentY = 20
'Print text
.ForeColor = RGB(255, 0, 0)
Me.Print CStr(Player(A).Score)
End With
Next
End Sub
Private Sub GameOver(iWinner As Long)
Dim A As Long
'Beeps
For A = 0 To 4: Beep: Next
Player(iWinner).Score = Player(iWinner).Score + 1
'Play again?
If MsgBox(Player(iWinner).Name & " wins!" & vbNewLine & vbNewLine & "Play again?", vbInformation Or vbYesNo, "Game Over") = vbNo Then: Unload Me
End Sub
Private Sub InitBall(iObject As tObject)
With iObject
'Start position
.X = (Camera.w - .w) / 2
.Y = (Camera.h - .h) / 2
'Initial speed
.SpeedX = IIf(100 * Rnd > 50, BallSpeed, -BallSpeed)
.SpeedY = ((2 * Rnd) - 1) * BallSpeed
End With
'Release pressed keys
ReDim KD(255)
End Sub
Sub Main()
Dim Temp As Long
While Active
If Temp < GetTickCount Then
'Timing
Temp = GetTickCount + (1000 / MaxFPS)
'Interface
CheckKeys
MoveObjects
End If
If Active Then
'Get context
Me.Cls
Camera.DC = Me.hdc
'Update window
DrawObjects
DrawScore
Me.Refresh
End If
DoEvents
Wend
End Sub
Private Sub MoveObject(iObject As tObject)
Dim A As Long
With iObject
If .IsBall Then
For A = 0 To PlayerCount
If (.X + .w) > Player(A).Pad.X And (.Y + .h) > Player(A).Pad.Y Then
If .X < (Player(A).Pad.X + Player(A).Pad.w) And .Y < (Player(A).Pad.Y + Player(A).Pad.h) Then
'Change direction
.SpeedX = -(.SpeedX * BallAcceleration)
.SpeedY = ((2 * Rnd) - 1) * BallSpeed
End If
End If
Next
'Pre-check clipping
If (.X + .SpeedX) < 0 Then
GameOver 1
InitBall iObject
End If
If (.X + .SpeedX + .w) > Camera.w Then
GameOver 0
InitBall iObject
End If
If (.Y + .SpeedY) < 0 Then: .SpeedY = -.SpeedY
If (.Y + .SpeedY + .h) > Camera.h Then: .SpeedY = -.SpeedY
Else
'Pre-check clipping
If (.X + .SpeedX) < 0 Then: .SpeedX = -(.SpeedX * Friction)
If (.Y + .SpeedY) < 0 Then: .SpeedY = -(.SpeedY * Friction)
If (.X + .SpeedX + .w) > Camera.w Then: .SpeedX = -(.SpeedX * Friction)
If (.Y + .SpeedY + .h) > Camera.h Then: .SpeedY = -(.SpeedY * Friction)
End If
'Add speed to position
.X = (.X + .SpeedX)
.Y = (.Y + .SpeedY)
End With
End Sub
Private Sub MoveObjects()
Dim A As Long
'Move objects
For A = 0 To PlayerCount: MoveObject Player(A).Pad: Next
For A = 0 To BallCount: MoveObject Ball(A): Next
End Sub
Private Sub DrawObjects()
Dim A As Long
'Draw graphics
For A = 0 To PlayerCount: DrawObject Player(A).Pad: Next
For A = 0 To BallCount: DrawObject Ball(A): Next
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
KD(KeyCode) = True
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
KD(KeyCode) = False
End Sub
Private Sub Form_Load()
Dim A As Long
'General
Active = True
MaxFPS = 40
ReDim KD(255)
PadSpeed = 10
PadAcceleration = 1
BallSpeed = 5
BallAcceleration = 1.1
Friction = 0.5
'Setup window
With Me
'General
.Caption = "PCEPR-Game: Ping-Pong"
'Drawing
.BackColor = 0
.ScaleMode = vbPixels
.FillStyle = 0
.Font = "Fixedsys"
.FontSize = 9
.AutoRedraw = True
'Size and position
.Width = 9000
.Height = 7000
.Move (Screen.Width - .Width) / 2, (Screen.Height - .Height) / 2
End With
'Allocate memory
PlayerCount = 1
ReDim Player(1)
BallCount = 0
ReDim Ball(BallCount)
'Setup objects
A = 0
With Player(A)
.Name = InputBox("Enter name for player " & CStr(A) & ":", "New player")
With .KeyTable
'Keys
.KeyUp = vbKeyA
.KeyDown = vbKeyY
End With
With .Pad
'Size
.w = 10
.h = 100
'Start position
.X = 10
.Y = (Camera.h - .h) / 2
'Movement
.SpeedX = 0
.SpeedY = 0
'General
.IsBall = False
.Color = RGB(0, 0, 255)
End With
End With
A = 1
With Player(A)
.Name = InputBox("Enter name for player " & CStr(A) & ":", "New player")
With .KeyTable
'Keys
.KeyUp = vbKeyK
.KeyDown = vbKeyM
End With
With .Pad
'Size
.w = 10
.h = 100
'Start position
.X = Camera.w - .w - 10
.Y = (Camera.h - .h) / 2
'Movement
.SpeedX = 0
.SpeedY = 0
'General
.IsBall = False
.Color = RGB(0, 255, 0)
End With
End With
For A = 0 To BallCount
With Ball(A)
'Size
.w = 20
.h = 20
InitBall Ball(A)
'General
.IsBall = True
.Color = RGB(255, 0, 0)
End With
Next
'Run
Me.Show
Main
End Sub
Private Sub Form_Resize()
If Active Then
With Camera
'Screen size
.w = Me.ScaleWidth
.h = Me.ScaleHeight
'General
.DC = Me.hdc
End With
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Active = False
End Sub
