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 [email][email protected][/email]
'Written on 2003-04-21
'Visit [url]http://vbfx.yhoko.com/[/url]
 
'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