VB6 - CPP: Pong [source]

[Fox]

Erm... well *g* Open a new project, add the following code and run.
Remember to delete the default "Form_Load" sub before copying.
There's 2 postings because it was too long for one.


'Copy-Pong by fox@yhoko.com
'Written on 2003-04-21
'Visit http://vbfx.yhoko.com/

'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 iDC 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)
Dim Temp As tKeyTable

'Draw object rect
With iObject
Me.FillColor = .Color
Me.ForeColor = .Color

If .IsBall Then
Me.Circle (CLng(.x), CLng(.y)), .w
Else
Rectangle Camera.DC, CLng(.x), CLng(.y), CLng(.x + .w), CLng(.y + .h)
End If
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

If Active Then
'Get context
Me.Cls
Camera.DC = Me.hdc

'Update window
DrawObjects
DrawScore

Me.Refresh
End If
End If

DoEvents
Wend
End Sub

[Fox]

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) Then
If .y < (Player(A).Pad.y + Player(A).Pad.h) Then
'Change direction
.SpeedX = -(.SpeedX * BallAcceleration)
.SpeedY = ((2 * Rnd) - 1) * BallSpeed
End If
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
Dim Temp As String

'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 = "CPP (Copy-Paste-Project): 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)

'User setup
A = 0
With Player(A)
.Name = InputBox("Enter name for player " & CStr(A + 1) & ":", "New player")

With .KeyTable
'Keys
.KeyUp = vbKeyA
.KeyDown = vbKeyY 'vbKeyZ
End With

'Individual setup
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

'Key-help
Temp = Temp & "Player " & CStr(A + 1) & ": " & Chr(Player(A).KeyTable.KeyUp) & _
" and " & Chr(Player(A).KeyTable.KeyDown) & vbNewLine
End With

A = 1
With Player(A)
.Name = InputBox("Enter name for player " & CStr(A + 1) & ":", "New player")

With .KeyTable
'Keys
.KeyUp = vbKeyK
.KeyDown = vbKeyM
End With

'Individual setup
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

'Key-help
Temp = Temp & "Player " & CStr(A + 1) & ": " & Chr(Player(A).KeyTable.KeyUp) & _
" and " & Chr(Player(A).KeyTable.KeyDown) & vbNewLine
End With

MsgBox "Key configuration:" & vbNewLine & vbNewLine & Temp, vbInformation

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