Skip to main content
Tweeted twitter.com/StackCodeReview/status/1048316948008882176
Source Link

Space Invader Style Game - Model / Presenter Decoupled From View - Functional Again Too

Thank you for your patience. The game is fully functional again!

I have tried to incorporate all the advice I have received so far. Thank you for taking the time to review and comment.

I have now decoupled the Model / Presenter from the View as much as VBA allows (please correct me if wrong). There are two functions from inside the view which the presenter calls. One of these functions ends the game, the other takes in a collection which the view promptly displays to the player.

When your ship collides with a space object you get a game over message box and then the userform unloads, an upgrade over the previous version which lead to crashes when you tried to run game twice.

Rather than throwing all of the spaceobjects into a single collection I have kept the separate collections for each "type" of spaceobject; incoming, missile and ship. Separate Collections for these objects makes handling collisions and object removal more manageable.

In the immediate term I want to re introduce scoring and a missile count limit. Also I need to fix the scaling of the objects. I have them in a ratio with gameboard height / width. Somehow it was not working for me? Then I am thinking about heat seeking missiles (give me a chance to work on algorithim stuff a bit, should be fun)

You can find the workbook here:

https://github.com/Evanml2030/SpaceInvader

Note that you cannot import and run Gameboard.frm without the corresponding Gameboard.frx file. Frx is a proprietary Microsoft file type that degenerates into alien symbols inside notepad, not sure how to link here.

Also note that StopWatch, BoardDimensions and each of the Collections have

Attribute VB_PredeclaredId = True

Big ups to:

StopWatch was put together by the fellow who runs bytecomb, a great site for vba tips. Link: https://bytecomb.com/accurate-performance-timers-in-vba/

GameBoard.frm:

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} GameBoard 
   Caption         =   "UserForm1"
   ClientHeight    =   9495
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   10095
   OleObjectBlob   =   "GameBoard.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "GameBoard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub UserForm_Activate()
    GameLogic.RunGame Me.InsideHeight, Me.InsideWidth
End Sub

Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim passVal                                                         As Long
    Select Case KeyCode.Value
    Case 37, 39, 32
        passVal = CInt(KeyCode)
        GameLogic.HandleSendKeys passVal
    End Select
End Sub

Public Sub RefreshGameBoard(ByVal ControlsToAdd As Collection)
    Dim Ctrl                                                            As Image
    Dim SpaceObjectIndex                                                As Variant

    For Each Ctrl In Me.Controls
        Me.Controls.Remove Ctrl.Name
    Next Ctrl
    
    For SpaceObjectIndex = 1 To ControlsToAdd.Count
        Set Ctrl = Me.Controls.Add("Forms.Image.1", ControlsToAdd.Item(SpaceObjectIndex).Name, True)
        Ctrl.Left = ControlsToAdd.Item(SpaceObjectIndex).Left
        Ctrl.Top = ControlsToAdd.Item(SpaceObjectIndex).Top
        Ctrl.Height = ControlsToAdd.Item(SpaceObjectIndex).Height
        Ctrl.Width = ControlsToAdd.Item(SpaceObjectIndex).Width
        Ctrl.Picture = LoadPicture(LinkToImage(ControlsToAdd.Item(SpaceObjectIndex).SpaceObjectType))
        Ctrl.PictureSizeMode = fmPictureSizeModeStretch
    Next SpaceObjectIndex
End Sub

Public Sub CloseGame()
    MsgBox "GAMEOVER"
    Unload Me
End Sub

Private Function LinkToImage(ByVal SpaceObjectType As SpaceObjectType) As String
    Select Case SpaceObjectType
    Case Alien
        LinkToImage = "C:\Users\evanm\OneDrive\Desktop\Excel\SpaceInvader\AlienShip.jpg"
    Case Comet
        LinkToImage = "C:\Users\evanm\OneDrive\Desktop\Excel\SpaceInvader\Comet.jpg"
    Case Star
        LinkToImage = "C:\Users\evanm\OneDrive\Desktop\Excel\SpaceInvader\Star.jpg"
    Case Missile
        LinkToImage = "C:\Users\evanm\OneDrive\Desktop\Excel\SpaceInvader\Missile.jpg"
    Case Ship
        LinkToImage = "C:\Users\evanm\OneDrive\Desktop\Excel\SpaceInvader\SpaceShip.jpg"
    End Select
End Function

GameLogic.bas:

Attribute VB_Name = "GameLogic"
Option Explicit

Public Enum SpaceObjectType
    Alien = 1
    Comet = 2
    Star = 3
    Missile = 4
    Ship = 5
End Enum

Public Enum PlayerShipHit
    Hit = 1
    NotHit = 0
End Enum

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Const Interval = 3

Sub RunGame(ByVal BoardWith As Long, ByVal BoardHeight As Long)
    Dim SleepWatch                                                          As StopWatch
    Dim GenerateIncSpaceObjectsRound1                                       As StopWatch
    
    BoardDimensions.Width = BoardWith
    BoardDimensions.Height = BoardHeight
    
    Set SleepWatch = New StopWatch
    SleepWatch.Start
    
    Set GenerateIncSpaceObjectsRound1 = New StopWatch
    GenerateIncSpaceObjectsRound1.Start

    InitializePlayerShip

    Do
        GameBoard.RefreshGameBoard CombineCollections
        
        MoveSpaceObjects.MoveIncomingMissiles
        MoveSpaceObjects.MoveIncomingSpaceObjects
        
        Collisions.HandleMissileCollisions
        If Collisions.HandleShipCollisions Then Exit Do
        
        If Format(GenerateIncSpaceObjectsRound1.Elapsed, "0.000000") > 3.25 Then
            ReleaseIncomingSpaceObject
            ReleaseIncomingSpaceObject
            ReleaseIncomingSpaceObject
            GenerateIncSpaceObjectsRound1.Restart
        End If
        
        If Format(SleepWatch.Elapsed, "0.000000") < Interval Then
            Sleep Interval - Format(SleepWatch.Elapsed, "0.000000")
            SleepWatch.Restart
        End If
        
        DoEvents
    Loop
    
    GameBoard.CloseGame
End Sub

Public Sub HandleSendKeys(ByVal KeyCode As Long)
    Select Case KeyCode
    Case 37
        MoveSpaceObjects.MoveShip Left
    Case 39
        MoveSpaceObjects.MoveShip Right
    Case 32
        LaunchMissile
    End Select
End Sub

Private Function InitializePlayerShip()
    Dim PlayerShip                                                          As ISpaceObject
    Set PlayerShip = SpaceObjectFactory.NewSpaceObject(Ship)
    CollectionShips.Add PlayerShip
End Function

Private Function LaunchMissile()
    Dim LaunchedMissile                                                     As ISpaceObject
    Set LaunchedMissile = SpaceObjectFactory.NewSpaceObject(Missile)
    CollectionMissiles.Add LaunchedMissile
End Function

Private Function ReleaseIncomingSpaceObject()
    Dim IncomingSpaceObject                                                 As ISpaceObject
    Set IncomingSpaceObject = SpaceObjectFactory.NewSpaceObject(Application.WorksheetFunction.RandBetween(1, 3))
    CollectionIncomingSpaceObjects.Add IncomingSpaceObject
End Function

Private Function CombineCollections() As Collection
    Dim ISpaceObjectIndex                                                   As Long

    Set CombineCollections = New Collection

    For ISpaceObjectIndex = 1 To CollectionIncomingSpaceObjects.Count
        CombineCollections.Add CollectionIncomingSpaceObjects.Item(ISpaceObjectIndex)
    Next ISpaceObjectIndex
    
    For ISpaceObjectIndex = 1 To CollectionMissiles.Count
        CombineCollections.Add CollectionMissiles.Item(ISpaceObjectIndex)
    Next ISpaceObjectIndex
    
    For ISpaceObjectIndex = 1 To CollectionShips.Count
        CombineCollections.Add CollectionShips.Item(ISpaceObjectIndex)
    Next ISpaceObjectIndex
End Function

MoveSpaceObjects.bas:

Attribute VB_Name = "MoveSpaceObjects"
Option Explicit

Public Enum Direction
    Left = 0
    Right = 1
End Enum

Sub MoveIncomingMissiles()
    Dim SpaceObjectIndex                                                    As Variant

    For SpaceObjectIndex = CollectionMissiles.Count To 1 Step -1
        If CollectionMissiles.Item(SpaceObjectIndex).Top - 3 <= 0 Then
            CollectionMissiles.Remove SpaceObjectIndex
        Else
            CollectionMissiles.Item(SpaceObjectIndex).Top = CollectionMissiles.Item(SpaceObjectIndex).Top - 3
        End If
    Next SpaceObjectIndex
End Sub

Sub MoveIncomingSpaceObjects()
    Dim SpaceObjectIndex                                                    As Variant

    For SpaceObjectIndex = CollectionIncomingSpaceObjects.Count To 1 Step -1
        If CollectionIncomingSpaceObjects.Item(SpaceObjectIndex).Top + 3 >= BoardDimensions.Height Then
            CollectionIncomingSpaceObjects.Remove SpaceObjectIndex
        Else
            CollectionIncomingSpaceObjects.Item(SpaceObjectIndex).Top = CollectionIncomingSpaceObjects.Item(SpaceObjectIndex).Top + 3
        End If
    Next SpaceObjectIndex
End Sub

Sub MoveShip(ByVal MoveShipDirection As Direction)
    Select Case MoveShipDirection
    Case Direction.Left
        If CollectionShips.Item(1).Left - 4 >= 0 Then
            CollectionShips.Item(1).Left = CollectionShips.Item(1).Left - 5
        Else
            CollectionShips.Item(1).Left = 0
        End If
    Case Direction.Right
        If (CollectionShips.Item(1).Left + CollectionShips.Item(1).Width) < BoardDimensions.Width Then
            CollectionShips.Item(1).Left = CollectionShips.Item(1).Left + 4
        Else
            CollectionShips.Item(1).Left = BoardDimensions.Width - CollectionShips.Item(1).Width
        End If
    End Select
End Sub

SpaceObjectFactory.bas

Attribute VB_Name = "SpaceObjectFactory"
Option Explicit

Public Function NewSpaceObject(ByVal SpaceObjectType As SpaceObjectType) As Spaceobject
    Select Case SpaceObjectType
    Case Alien
        Set NewSpaceObject = NewSpaceObjectAlien
    Case Comet
        Set NewSpaceObject = NewSpaceObjectComet
    Case Missile
        Set NewSpaceObject = NewSpaceObjectMissile
    Case Ship
        Set NewSpaceObject = NewSpaceObjectShip
    Case Star
        Set NewSpaceObject = NewSpaceObjectStar
    End Select
End Function

Private Function NewSpaceObjectAlien() As Spaceobject
    With New Spaceobject
        .SetInitialLeft Application.WorksheetFunction.RandBetween(1, BoardDimensions.Width)
        .SetInitialTop 1
        .Height = BoardDimensions.Width / 10
        .Width = BoardDimensions.Width / 10
        .SpaceObjectType = Alien
        .Name = "INCSPACEOBJECT" & CollectionIncomingSpaceObjects.Count
        Set NewSpaceObjectAlien = .Self
    End With
End Function

Private Function NewSpaceObjectComet() As Spaceobject
    With New Spaceobject
        .SetInitialLeft Application.WorksheetFunction.RandBetween(1, BoardDimensions.Width)
        .SetInitialTop 1
        .Height = BoardDimensions.Height / 7
        .Width = BoardDimensions.Height / 7
        .SpaceObjectType = Comet
        .Name = "INCSPACEOBJECT" & CollectionIncomingSpaceObjects.Count
        Set NewSpaceObjectComet = .Self
    End With
End Function

Private Function NewSpaceObjectMissile() As Spaceobject
    With New Spaceobject
        .SetInitialLeft ((CollectionShips.Item(1).Width - (BoardDimensions.Width / 20)) / 2) + CollectionShips.Item(1).Left
        .SetInitialTop CollectionShips.Item(1).Top - BoardDimensions.Height / 15
        .Height = BoardDimensions.Height / 15
        .Width = BoardDimensions.Height / 20
        .SpaceObjectType = Missile
        .Name = "MISSILE" & CollectionMissiles.Count
        Set NewSpaceObjectMissile = .Self
    End With
End Function

Private Function NewSpaceObjectShip() As Spaceobject
    With New Spaceobject
        .SetInitialLeft BoardDimensions.Width / 2 - ((BoardDimensions.Height / 7) / 2)
        .SetInitialTop Round(BoardDimensions.Height - ((BoardDimensions.Height / 7) * 1.25), 0)
        .Height = BoardDimensions.Height / 7
        .Width = BoardDimensions.Width / 7
        .SpaceObjectType = Ship
        .Name = "SHIP"
        Set NewSpaceObjectShip = .Self
    End With
End Function

Private Function NewSpaceObjectStar() As Spaceobject
    With New Spaceobject
        .SetInitialLeft Application.WorksheetFunction.RandBetween(1, BoardDimensions.Width)
        .SetInitialTop 1
        .Height = BoardDimensions.Height / 5
        .Width = BoardDimensions.Height / 5
        .SpaceObjectType = Star
        .Name = "INCSPACEOBJECT" & CollectionIncomingSpaceObjects.Count
        Set NewSpaceObjectStar = .Self
    End With
End Function

Collisions.bas:

Attribute VB_Name = "Collisions"
Option Explicit

Sub HandleMissileCollisions()
    Dim MissileObject                                                       As ISpaceObject
    Dim IncomingSpaceObject                                                 As ISpaceObject
    Dim MissileObjectsIndex                                                 As Long
    Dim IncomingSpaceObjectIndex                                            As Long

    For MissileObjectsIndex = CollectionMissiles.Count To 1 Step -1
        Set MissileObject = CollectionMissiles.Item(MissileObjectsIndex)
        For IncomingSpaceObjectIndex = CollectionIncomingSpaceObjects.Count To 1 Step -1
            Set IncomingSpaceObject = CollectionIncomingSpaceObjects.Item(IncomingSpaceObjectIndex)
            If CheckIfCollided(MissileObject, IncomingSpaceObject) Then
                CollectionMissiles.Remove MissileObjectsIndex
                CollectionIncomingSpaceObjects.Remove IncomingSpaceObjectIndex
                Exit For
            End If
        Next IncomingSpaceObjectIndex
    Next MissileObjectsIndex
End Sub

Function HandleShipCollisions() As Boolean
    Dim ShipObject                                                          As ISpaceObject
    Dim IncomingSpaceObject                                                 As ISpaceObject
    Dim ShipObjectIndex                                                     As Long
    Dim IncomingSpaceObjectIndex                                            As Long

    For ShipObjectIndex = CollectionShips.Count To 1 Step -1
        Set ShipObject = CollectionShips.Item(ShipObjectIndex)
        For IncomingSpaceObjectIndex = CollectionIncomingSpaceObjects.Count To 1 Step -1
            Set IncomingSpaceObject = CollectionIncomingSpaceObjects.Item(IncomingSpaceObjectIndex)
            If CheckIfCollided(ShipObject, IncomingSpaceObject) Then
                HandleShipCollisions = True
                Exit For
            End If
        Next IncomingSpaceObjectIndex
    Next ShipObjectIndex
End Function

Private Function CheckIfCollided(ByVal First As ISpaceObject, ByVal Second As ISpaceObject) As Boolean
    Dim HorizontalOverlap                                                   As Boolean
    Dim VerticalOverlap                                                     As Boolean

    HorizontalOverlap = (First.Left - Second.Width < Second.Left) And (Second.Left < First.Left + First.Width)
    VerticalOverlap = (First.Top - Second.Height < Second.Top) And (Second.Top < First.Top + First.Height)
    CheckIfCollided = HorizontalOverlap And VerticalOverlap
End Function

CollectionMissiles.cls:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CollectionMissiles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private CollectionMissiles As Collection
Private pCount As Long

Private Sub Class_Initialize()
    Set CollectionMissiles = New Collection
End Sub

Private Sub Class_Terminate()
    Set CollectionMissiles = Nothing
End Sub

Public Sub Add(obj As ISpaceObject)
    CollectionMissiles.Add obj
End Sub

Public Sub Remove(index As Variant)
    CollectionMissiles.Remove index
End Sub

Public Property Get Item(index As Variant) As ISpaceObject
    Set Item = CollectionMissiles.Item(index)
End Property

Property Get Count() As Long
    Count = CollectionMissiles.Count
End Property

Public Sub Clear()
    Set CollectionMissiles = New Collection
End Sub

CollectionIncomingSpaceObjects.cls:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CollectionIncomingSpaceObjects"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private CollectionIncomingSpaceObjects As Collection

Private Sub Class_Initialize()
    Set CollectionIncomingSpaceObjects = New Collection
End Sub

Private Sub Class_Terminate()
    Set CollectionIncomingSpaceObjects = Nothing
End Sub

Public Sub Add(obj As ISpaceObject)
    CollectionIncomingSpaceObjects.Add obj
End Sub

Public Sub Remove(index As Variant)
    CollectionIncomingSpaceObjects.Remove index
End Sub

Public Property Get Item(index As Variant) As ISpaceObject
    Set Item = CollectionIncomingSpaceObjects.Item(index)
End Property

Property Get Count() As Long
    Count = CollectionIncomingSpaceObjects.Count
End Property

Public Sub Clear()
    Set CollectionIncomingSpaceObjects = New Collection
End Sub

CollectionShips.cls:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CollectionShips"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private CollectionShips As Collection
Private pCount As Long

Private Sub Class_Initialize()
    Set CollectionShips = New Collection
End Sub

Private Sub Class_Terminate()
    Set CollectionShips = Nothing
End Sub

Public Sub Add(obj As ISpaceObject)
    CollectionShips.Add obj
End Sub

Public Sub Remove(index As Variant)
    CollectionShips.Remove index
End Sub

Public Property Get Item(index As Variant) As ISpaceObject
    Set Item = CollectionShips.Item(index)
End Property

Property Get Count() As Long
    Count = CollectionShips.Count
End Property

Public Sub Clear()
    Set CollectionShips = New Collection
End Sub

ISpaceObject.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ISpaceObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Property Let Left(ByVal changeLeft As Long)
End Property

Public Property Get Left() As Long
End Property

Public Property Let Top(ByVal changeTop As Long)
End Property

Public Property Get Top() As Long
End Property

Public Property Get Width() As Long
End Property

Public Property Get Height() As Long
End Property

Public Property Get Name() As String
End Property

Public Property Get SpaceObjectType() As SpaceObjectType
End Property

Private Function IsMissile() As Boolean
End Function

Private Function IsIncomingSpaceObject() As Boolean
End Function

BoardDimensions.cls:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BoardDimensions"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type BoardDimensionsData
    Width As Long
    Height As Long
End Type

Private this As BoardDimensionsData

Public Property Let Width(ByVal Width As Long)
    this.Width = Width
End Property

Public Property Get Width() As Long
    Width = this.Width
End Property

Public Property Let Height(ByVal Height As Long)
    this.Height = Height
End Property

Public Property Get Height() As Long
    Height = this.Height
End Property

StopWatch.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "StopWatch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" ( _
lpPerformanceCount As UINT64) As Long

Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" ( _
lpFrequency As UINT64) As Long

Private pFrequency                                                          As Double
Private pStartTS                                                            As UINT64
Private pEndTS                                                              As UINT64
Private pElapsed                                                            As Double
Private pRunning                                                            As Boolean

Private Type UINT64
    LowPart                                                                 As Long
    HighPart                                                                As Long
End Type

Private Const BSHIFT_32 = 4294967296#            ' 2 ^ 32

Private Function U64Dbl(U64 As UINT64) As Double
    Dim lDbl                                                                As Double
    Dim hDbl                                                                As Double
    lDbl = U64.LowPart
    hDbl = U64.HighPart
    If lDbl < 0 Then lDbl = lDbl + BSHIFT_32
    If hDbl < 0 Then hDbl = hDbl + BSHIFT_32
    U64Dbl = lDbl + BSHIFT_32 * hDbl
End Function

Private Sub Class_Initialize()
    Dim PerfFrequency As UINT64
    QueryPerformanceFrequency PerfFrequency
    pFrequency = U64Dbl(PerfFrequency)
End Sub

Public Property Get Elapsed() As Double
    If pRunning Then
        Dim pNow As UINT64
        QueryPerformanceCounter pNow
        Elapsed = pElapsed + (U64Dbl(pNow) - U64Dbl(pStartTS)) / pFrequency
    Else
        Elapsed = pElapsed
    End If
End Property

Public Sub Start()
    If Not pRunning Then
        QueryPerformanceCounter pStartTS
        pRunning = True
    End If
End Sub

Public Sub Pause()
    If pRunning Then
        QueryPerformanceCounter pEndTS
        pRunning = False
        pElapsed = pElapsed + (U64Dbl(pEndTS) - U64Dbl(pStartTS)) / pFrequency
    End If
End Sub

Public Sub Reset()
    pElapsed = 0
    pRunning = False
End Sub

Public Sub Restart()
    pElapsed = 0
    QueryPerformanceCounter pStartTS
    pRunning = True
End Sub

Public Property Get Running() As Boolean
    Running = pRunning
End Property