BattleShip Grid: Classes and Tests

Question

In my ongoing quest to demonstrate how VBA code can absolutely be object-oriented, I've started implementing a game of Battleship in pure VBA.

This is a rather large project, so I'll split the reviewing across multiple posts. This first one covers the coordinate/grid system.

Each module in the project is annotated with a @Folder annotation, which Rubberduck uses to organize the modules into a folder hierarchy, making the rather large project easy to navigate despite the poorly tooled IDE; other annotations include:

• @IgnoreModule prevents static code analysis from firing results in that module.
• @Description will eventually translate into VB_Description attributes; until then they serve as descriptive comments for public members, where appropriate.

The GridCoord class module has a VB_PredeclaredId = True module attribute which gives it a default instance; I'm only ever using this default instance to invoke the Create factory method, which serves as a public parameterized constructor for the class.

The ToString method gives a representation in the form of (x,y) that can be used internally, and easily round-trips back to a GridCoord instance; the ToA1String method yields a string representation that can easily be used by the game to display e.g. the selected grid coordinate. That format is just for display, and does not round-trip.

'@Folder("Battleship.Model")
'@IgnoreModule UseMeaningfulName; X and Y are perfectly fine names here.
Option Explicit

Private Type TGridCoord
    X As Long
    Y As Long
End Type

Private this As TGridCoord

Public Function Create(ByVal xPosition As Long, ByVal yPosition As Long) As GridCoord
    With New GridCoord
        .X = xPosition
        .Y = yPosition
        Set Create = .Self
    End With
End Function

Public Function FromString(ByVal coord As String) As GridCoord
    coord = Replace(Replace(coord, "(", vbNullString), ")", vbNullString)

    Dim coords As Variant
    coords = Split(coord, ",")

    Dim xPosition As Long
    xPosition = coords(LBound(coords))

    Dim yPosition As Long
    yPosition = coords(UBound(coords))

    Set FromString = Create(xPosition, yPosition)
End Function

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

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

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

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

Public Property Get Self() As GridCoord
    Set Self = Me
End Property

Public Property Get Default() As GridCoord
    Set Default = New GridCoord
End Property

Public Function ToString() As String
    ToString = "(" & this.X & "," & this.Y & ")"
End Function

Public Function ToA1String() As String
    ToA1String = Chr$(64 + this.X) & this.Y
End Function

Public Function Equals(ByVal other As GridCoord) As Boolean
    Equals = other.X = this.X And other.Y = this.Y
End Function

Public Function Offset(Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As GridCoord
    Set Offset = GridCoord.Create(this.X + xOffset, this.Y + yOffset)
End Function

Public Function IsAdjacent(ByVal other As GridCoord) As Boolean
    If other.Y = this.Y Then
        IsAdjacent = other.X = this.X - 1 Or other.X = this.X + 1
    ElseIf other.X = this.X Then
        IsAdjacent = other.Y = this.Y - 1 Or other.Y = this.Y + 1
    End If
End Function

The GridCoordTests module is a Rubberduck test module that includes 16 passing tests that demonstrate usage and validate the type's behavior.

'@TestModule
'@Folder("Tests")
Option Explicit
Option Private Module

Private Assert As Rubberduck.AssertClass
'Private Fakes As Rubberduck.FakesProvider

'@ModuleInitialize
Public Sub ModuleInitialize()
    Set Assert = CreateObject("Rubberduck.AssertClass")
    'Set Fakes = CreateObject("Rubberduck.FakesProvider")
End Sub

'@ModuleCleanup
Public Sub ModuleCleanup()
    Set Assert = Nothing
    'Set Fakes = Nothing
End Sub

'@TestMethod
Public Sub CreatesAtSpecifiedXCoordinate()
    Const expectedX As Long = 42
    Const expectedY As Long = 74

    Dim sut As GridCoord
    Set sut = GridCoord.Create(expectedX, expectedY)

    Assert.AreEqual expectedX, sut.X, "X coordinate mismatched."
    Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched."
End Sub

'@TestMethod
Public Sub DefaultIsZeroAndZero()
    Const expectedX As Long = 0
    Const expectedY As Long = 0

    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Assert.AreEqual expectedX, sut.X, "X coordinate mismatched."
    Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched."
End Sub

'@TestMethod
Public Sub OffsetAddsX()
    Const xOffset As Long = 1
    Const yOffset As Long = 0

    Dim initial As GridCoord
    Set initial = GridCoord.Default

    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Dim actual As GridCoord
    Set actual = sut.Offset(xOffset, yOffset)

    Assert.AreEqual initial.X + xOffset, actual.X
End Sub

'@TestMethod
Public Sub OffsetAddsY()
    Const xOffset As Long = 0
    Const yOffset As Long = 1

    Dim initial As GridCoord
    Set initial = GridCoord.Default

    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Dim actual As GridCoord
    Set actual = sut.Offset(xOffset, yOffset)

    Assert.AreEqual initial.Y + yOffset, actual.Y
End Sub

'@TestMethod
Public Sub FromToString_RoundTrips()
    Dim initial As GridCoord
    Set initial = GridCoord.Default

    Dim asString As String
    asString = initial.ToString

    Dim sut As GridCoord
    Set sut = GridCoord.FromString(asString)

    Assert.AreEqual initial.X, sut.X, "X coordinate mismatched."
    Assert.AreEqual initial.Y, sut.Y, "Y coordinate mismatched."
End Sub

'@TestMethod
Public Sub ToStringFormat_NoSpaceCommaSeparatedInParentheses()
    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Dim expected As String
    expected = "(" & sut.X & "," & sut.Y & ")"

    Dim actual As String
    actual = sut.ToString

    Assert.AreEqual expected, actual
End Sub

'@TestMethod
Public Sub EqualsReturnsTrueForMatchingCoords()
    Dim other As GridCoord
    Set other = GridCoord.Default

    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Assert.IsTrue sut.Equals(other)
End Sub

'@TestMethod
Public Sub EqualsReturnsFalseForMismatchingCoords()
    Dim other As GridCoord
    Set other = GridCoord.Default.Offset(1)

    Dim sut As GridCoord
    Set sut = GridCoord.Default

    Assert.IsFalse sut.Equals(other)
End Sub

'@TestMethod
Public Sub GivenOneLeftAndSameY_IsAdjacentReturnsTrue()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(2, 1)

    Assert.IsTrue sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenTwoLeftAndSameY_IsAdjacentReturnsFalse()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(3, 1)

    Assert.IsFalse sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenOneRightAndSameY_IsAdjacentReturnsTrue()
    Dim other As GridCoord
    Set other = GridCoord.Create(3, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(2, 1)

    Assert.IsTrue sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenTwoRightAndSameY_IsAdjacentReturnsFalse()
    Dim other As GridCoord
    Set other = GridCoord.Create(5, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(3, 1)

    Assert.IsFalse sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenOneDownAndSameX_IsAdjacentReturnsTrue()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 2)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(1, 1)

    Assert.IsTrue sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenTwoDownAndSameX_IsAdjacentReturnsFalse()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 3)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(1, 1)

    Assert.IsFalse sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenOneUpAndSameX_IsAdjacentReturnsTrue()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(1, 2)

    Assert.IsTrue sut.IsAdjacent(other)
End Sub

'@TestMethod
Public Sub GivenTwoUpAndSameX_IsAdjacentReturnsFalse()
    Dim other As GridCoord
    Set other = GridCoord.Create(1, 1)

    Dim sut As GridCoord
    Set sut = GridCoord.Create(1, 3)

    Assert.IsFalse sut.IsAdjacent(other)
End Sub

---

The PlayerGrid class also has a VB_PredeclaredId = True module attribute; again, the class' default instance is never used to store any state. The Create method serves as a public parameterized constructor for the class. The type represents a player's game grid, and encapsulates its state.

'@Folder("Battleship.Model.Player")
Option Explicit

Private Const KnownGridStateErrorMsg As String _
    = "Specified coordinate is not in an unknown state."
Private Const CannotAddShipAtPositionMsg As String _
    = "Cannot add a ship of this size at this position."
Private Const CannotAddMoreShipsMsg As String _
    = "Cannot add more ships to this grid."

Public Enum PlayerGridErrors
    KnownGridStateError = vbObjectError Or 127
    CannotAddShipAtPosition
    CannotAddMoreShips
End Enum

Public Enum AttackResult
    Miss
    Hit
    Sunk
End Enum

Public Enum GridState
    '@Description("Content at this coordinate is unknown.")
    Unknown = -1
    '@Description("Unconfirmed friendly ship position.")
    PreviewShipPosition = 0
    '@Description("Confirmed friendly ship position.")
    ShipPosition = 1
    '@Description("Unconfirmed invalid/overlapping ship position.")
    InvalidPosition = 2
    '@Description("No ship at this coordinate.")
    PreviousMiss = 3
    '@Description("An enemy ship occupies this coordinate.")
    PreviousHit = 4
End Enum

Private Type TPlayGrid
    Id As Byte
    ships As Collection
    State(1 To Globals.GridSize, 1 To Globals.GridSize) As GridState
End Type

Private this As TPlayGrid

Public Function Create(ByVal grid As Byte) As PlayerGrid
    With New PlayerGrid
        .GridId = grid
        Set Create = .Self
    End With
End Function

'@Description("Gets the ID of this grid. 1 for Player1, 2 for Player2.")
Public Property Get GridId() As Byte
    GridId = this.Id
End Property

Public Property Let GridId(ByVal value As Byte)
    this.Id = value
End Property

Public Property Get Self() As PlayerGrid
    Set Self = Me
End Property

'@Description("Gets the number of ships placed on the grid.")
Public Property Get ShipCount() As Long
    ShipCount = this.ships.Count
End Property

Private Sub Class_Initialize()
    Set this.ships = New Collection
    Dim currentX As Long
    For currentX = LBound(this.State, 1) To UBound(this.State, 1)
        Dim currentY As Long
        For currentY = LBound(this.State, 2) To UBound(this.State, 2)
            this.State(currentX, currentY) = GridState.Unknown
        Next
    Next
End Sub

'@Description("Adds the specified ship to the grid. Throws if position is illegal.")
Public Sub AddShip(ByVal item As IShip)

    If Not CanAddShip(item.GridPosition, item.orientation, item.size) Then
        Err.Raise PlayerGridErrors.CannotAddShipAtPosition, TypeName(Me), CannotAddShipAtPositionMsg
    End If

    If this.ships.Count >= Globals.ShipsPerGrid Then
        Err.Raise PlayerGridErrors.CannotAddMoreShips, TypeName(Me), CannotAddMoreShipsMsg
    End If

    ' will throw a duplicate key error if item.Name is already in collection
    this.ships.Add item, item.Name

    Dim currentX As Long
    For currentX = item.GridPosition.X To item.GridPosition.X + IIf(item.orientation = Horizontal, item.size - 1, 0)
        Dim currentY As Long
        For currentY = item.GridPosition.Y To item.GridPosition.Y + IIf(item.orientation = Vertical, item.size - 1, 0)
            this.State(currentX, currentY) = GridState.ShipPosition
        Next
    Next

End Sub

'@Description("Gets a value indicating whether a ship can be added at the specified position/direction/size.")
Public Function CanAddShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean
    CanAddShip = (position.X + IIf(direction = Horizontal, shipSize - 1, 0) <= UBound(this.State, 1)) _
             And (position.Y + IIf(direction = Vertical, shipSize - 1, 0) <= UBound(this.State, 2)) _
             And (position.X > 0 And position.Y > 0) _
             And IntersectsAny(position, direction, shipSize) Is Nothing
End Function

'@Description("Gets a value indicating whether the specified position/direction/size intersects with any existing ship.")
Public Function IntersectsAny(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As GridCoord
    Dim currentShip As IShip
    For Each currentShip In this.ships
        Dim intersecting As GridCoord
        Set intersecting = currentShip.Intersects(Ship.Create("InsersectCheck", shipSize, direction, position))
        If Not intersecting Is Nothing Then
            Set IntersectsAny = intersecting
            Exit Function
        End If
    Next
End Function

'@Description("Gets a value indicating whether the specified position/direction/size has any adjacent existing ship.")
Public Function HasAdjacentShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean

    Dim positionX As Long
    Dim positionY As Long

    If direction = Horizontal Then
        positionY = position.Y
        For positionX = position.X To position.X + shipSize - 1
            If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then
                HasAdjacentShip = True
                Exit Function
            End If
        Next
    Else
        positionX = position.X
        For positionY = position.Y To position.Y + shipSize - 1
            If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then
                HasAdjacentShip = True
                Exit Function
            End If
        Next
    End If
End Function

Private Function HasAnyAdjacentShips(ByVal coord As GridCoord) As Boolean
    Dim currentX As Long
    Dim currentY As Long
    Dim currentShip As IShip
    For Each currentShip In this.ships
        If currentShip.orientation = Horizontal Then
            currentY = currentShip.GridPosition.Y
            For currentX = currentShip.GridPosition.X To currentShip.GridPosition.X + currentShip.size - 1
                If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then
                    HasAnyAdjacentShips = True
                    Exit Function
                End If
            Next
        Else
            currentX = currentShip.GridPosition.X
            For currentY = currentShip.GridPosition.Y To currentShip.GridPosition.Y + currentShip.size - 1
                If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then
                    HasAnyAdjacentShips = True
                    Exit Function
                End If
            Next
        End If
    Next
End Function

'@Description("(side-effecting) Attempts a hit at the specified position; returns the result of the attack, and a reference to the hit ship if successful.")
Public Function TryHit(ByVal position As GridCoord, Optional ByRef hitShip As IShip) As AttackResult

    If this.State(position.X, position.Y) = GridState.PreviousHit Or _
       this.State(position.X, position.Y) = GridState.PreviousMiss Then
        Err.Raise PlayerGridErrors.KnownGridStateError, TypeName(Me), KnownGridStateErrorMsg
    End If

    Dim currentShip As IShip
    For Each currentShip In this.ships
        If currentShip.Hit(position) Then
            this.State(position.X, position.Y) = GridState.PreviousHit
            If currentShip.IsSunken Then
                TryHit = Sunk
            Else
                TryHit = Hit
            End If
            Set hitShip = currentShip
            Exit Function
        End If
    Next

    this.State(position.X, position.Y) = GridState.PreviousMiss
    TryHit = Miss

End Function

'@Description("Gets the GridState value at the specified position.")
Public Property Get State(ByVal position As GridCoord) As GridState
    On Error Resume Next
    State = this.State(position.X, position.Y)
    On Error GoTo 0
End Property

'@Description("Gets a 2D array containing the GridState of each coordinate in the grid.")
Public Property Get StateArray() As Variant
    Dim result(1 To Globals.GridSize, 1 To Globals.GridSize) As Variant
    Dim currentX As Long
    For currentX = 1 To Globals.GridSize
        Dim currentY As Long
        For currentY = 1 To Globals.GridSize
            Dim value As GridState
            value = this.State(currentX, currentY)
            result(currentX, currentY) = IIf(value = Unknown, Empty, value)
        Next
    Next
    StateArray = result
End Property

'@Description("Gets a value indicating whether the ship at the specified position is sunken.")
Public Property Get IsSunken(ByVal position As GridCoord) As Boolean
    Dim currentShip As IShip
    For Each currentShip In this.ships
        If currentShip.IsSunken Then
            If currentShip.orientation = Horizontal Then
                If currentShip.GridPosition.Y = position.Y Then
                    If position.X >= currentShip.GridPosition.X And _
                       position.X <= currentShip.GridPosition.X + currentShip.size - 1 _
                    Then
                        IsSunken = True
                        Exit Property
                    End If
                End If
            End If
        End If
    Next
End Property

'@Descrition("Gets a value indicating whether all ships have been sunken.")
Public Property Get IsAllSunken() As Boolean
    Dim currentShip As IShip
    For Each currentShip In this.ships
        If Not currentShip.IsSunken Then
            IsAllSunken = False
            Exit Property
        End If
    Next
    IsAllSunken = True
End Property

'@Description("Returns the GridCoord of known hits around the specified hit position.")
Public Function GetHitArea(ByVal position As GridCoord) As Collection
    Debug.Assert this.State(position.X, position.Y) = GridState.PreviousHit

    Dim result As Collection
    Set result = New Collection

    Dim currentX As Long
    Dim currentY As Long

    currentX = position.X
    currentY = position.Y

    Dim currentPosition As GridCoord

    If position.X > 1 Then
        Do While currentX >= 1 And this.State(currentX, currentY) = GridState.PreviousHit
            On Error Resume Next
            With GridCoord.Create(currentX, currentY)
                result.Add .Self, .ToString
            End With
            On Error GoTo 0
            currentX = currentX - 1
        Loop
    End If

    currentX = position.X
    currentY = position.Y

    If position.X < Globals.GridSize Then
        Do While currentX <= Globals.GridSize And this.State(currentX, currentY) = GridState.PreviousHit
            On Error Resume Next
            With GridCoord.Create(currentX, currentY)
                result.Add .Self, .ToString
            End With
            On Error GoTo 0
            currentX = currentX + 1
        Loop
    End If

    currentX = position.X
    currentY = position.Y

    If position.Y > 1 Then
        Do While currentY >= 1 And this.State(currentX, currentY) = GridState.PreviousHit
            On Error Resume Next
            With GridCoord.Create(currentX, currentY)
                result.Add .Self, .ToString
            End With
            On Error GoTo 0
            currentY = currentY - 1
        Loop
    End If

    currentX = position.X
    currentY = position.Y

    If position.Y < Globals.GridSize Then
        Do While currentY <= Globals.GridSize And this.State(currentX, currentY) = GridState.PreviousHit
            On Error Resume Next
            With GridCoord.Create(currentX, currentY)
                result.Add .Self, .ToString
            End With
            On Error GoTo 0
            currentY = currentY + 1
        Loop
    End If

    Set GetHitArea = result

End Function

'@Description("Removes confirmed ship positions from grid state.")
Public Sub Scramble()
    Dim currentX As Long
    For currentX = 1 To Globals.GridSize
        Dim currentY As Long
        For currentY = 1 To Globals.GridSize
            If this.State(currentX, currentY) = GridState.ShipPosition Then
                this.State(currentX, currentY) = GridState.Unknown
            End If
        Next
    Next
End Sub

The PlayerGridTests module is a Rubberduck test module including 19 passing tests that demonstrate usage and validate the type's behavior.

'@TestModule
'@Folder("Tests")
Option Explicit
Option Private Module

Private Assert As Rubberduck.AssertClass
'Private Fakes As Rubberduck.FakesProvider

'@ModuleInitialize
Public Sub ModuleInitialize()
    Set Assert = CreateObject("Rubberduck.AssertClass")
    'Set Fakes = CreateObject("Rubberduck.FakesProvider")
End Sub

'@ModuleCleanup
Public Sub ModuleCleanup()
    Set Assert = Nothing
    'Set Fakes = Nothing
End Sub

'@TestMethod
Public Sub CanAddShipInsideGridBoundaries_ReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    Assert.IsTrue sut.CanAddShip(position, Horizontal, Ship.MinimumSize)
End Sub

'@TestMethod
Public Sub CanAddShipAtPositionZeroZero_ReturnsFalse()
'i.e. PlayerGrid coordinates are 1-based
    Dim position As GridCoord
    Set position = GridCoord.Create(0, 0)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    Assert.IsFalse sut.CanAddShip(position, Horizontal, Ship.MinimumSize)
End Sub

'@TestMethod
Public Sub CanAddShipGivenInterectingShips_ReturnsFalse()
    Dim ship1 As IShip
    Set ship1 = Ship.Create("Ship1", 3, Horizontal, GridCoord.Create(1, 1))

    Dim ship2 As IShip
    Set ship2 = Ship.Create("Ship2", 3, Vertical, GridCoord.Create(2, 1))

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip ship1
    Assert.IsFalse sut.CanAddShip(ship2.GridPosition, ship2.orientation, ship2.size)
End Sub

'@TestMethod
Public Sub AddingSameShipNameTwice_Throws()
    Const ExpectedError As Long = 457 ' "This key is already associated with an element of this collection"
    On Error GoTo TestFail

    Const shipName As String = "TEST"

    Dim ship1 As IShip
    Set ship1 = Ship.Create(shipName, 2, Horizontal, GridCoord.Create(1, 1))

    Dim ship2 As IShip
    Set ship2 = Ship.Create(shipName, 3, Horizontal, GridCoord.Create(5, 5))

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip ship1
    sut.AddShip ship2

Assert:
    Assert.Fail "Expected error was not raised."

TestExit:
    Exit Sub
TestFail:
    If Err.Number = ExpectedError Then
        Resume TestExit
    Else
        Resume Assert
    End If
End Sub

'@TestMethod
Public Sub AddingShipOutsideGridBoundaries_Throws()
    Const ExpectedError As Long = PlayerGridErrors.CannotAddShipAtPosition
    On Error GoTo TestFail

    Dim ship1 As IShip
    Set ship1 = Ship.Create("TEST", 2, Horizontal, GridCoord.Create(0, 0))

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip ship1

Assert:
    Assert.Fail "Expected error was not raised."

TestExit:
    Exit Sub
TestFail:
    If Err.Number = ExpectedError Then
        Resume TestExit
    Else
        Resume Assert
    End If
End Sub

'@TestMethod
Public Sub AddingMoreShipsThanGameAllows_Throws()
    Const ExpectedError As Long = PlayerGridErrors.CannotAddMoreShips
    Const MaxValue As Long = Globals.ShipsPerGrid
    On Error GoTo TestFail

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    Dim i As Long
    For i = 1 To Globals.ShipsPerGrid
        sut.AddShip Ship.Create("TEST" & i, 2, Horizontal, GridCoord.Create(1, i))
    Next
    sut.AddShip Ship.Create("TEST" & MaxValue + i, 2, Horizontal, GridCoord.Create(1, MaxValue + 1))

Assert:
    Assert.Fail "Expected error was not raised."

TestExit:
    Exit Sub
TestFail:
    If Err.Number = ExpectedError Then
        Resume TestExit
    Else
        Resume Assert
    End If
End Sub

'@TestMethod
Public Sub TryHitKnownState_Throws()
    Const ExpectedError As Long = PlayerGridErrors.KnownGridStateError
    On Error GoTo TestFail

    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid
    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    sut.TryHit position
    sut.TryHit position

Assert:
    Assert.Fail "Expected error was not raised."

TestExit:
    Exit Sub
TestFail:
    If Err.Number = ExpectedError Then
        Resume TestExit
    Else
        Resume Assert
    End If
End Sub

'@TestMethod
Public Sub TryHitMiss_SetsPreviousMissState()
    Const expected = GridState.PreviousMiss

    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim badPosition As GridCoord
    Set badPosition = position.Offset(5, 5)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid
    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    sut.TryHit badPosition
    Dim actual As GridState
    actual = sut.State(badPosition)
    Assert.AreEqual expected, actual
End Sub

'@TestMethod
Public Sub TryHitSuccess_SetsPreviousHitState()
    Const expected = GridState.PreviousHit

    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid
    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    sut.TryHit position
    Dim actual As GridState
    actual = sut.State(position)
    Assert.AreEqual expected, actual
End Sub

'@TestMethod
Public Sub TryHitSuccess_ReturnsTrue()
    Const expected = GridState.PreviousHit

    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid
    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsTrue sut.TryHit(position)
End Sub

'@TestMethod
Public Sub TryHitMisses_ReturnsFalse()
    Const expected = GridState.PreviousMiss

    Dim position As GridCoord
    Set position = GridCoord.Create(1, 1)

    Dim badPosition As GridCoord
    Set badPosition = position.Offset(5, 5)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid
    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsFalse sut.TryHit(badPosition)
End Sub

'@TestMethod
Public Sub GridInitialState_UnknownState()
    Const expected = GridState.Unknown

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    Dim actual As GridState
    actual = sut.State(GridCoord.Create(1, 1))

    Assert.AreEqual expected, actual
End Sub

'@TestMethod
Public Sub GivenAdjacentShip_HasRightAdjacentShipReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(2, 2)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 2), Vertical, 3)
End Sub

'@TestMethod
Public Sub GivenAdjacentShip_HasLeftAdjacentShipReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(2, 1)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Vertical, 3)
End Sub

'@TestMethod
Public Sub GivenAdjacentShip_HasDownAdjacentShipReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(2, 2)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 3), Horizontal, 3)
End Sub

'@TestMethod
Public Sub GivenAdjacentShip_HasUpAdjacentShipReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(2, 2)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 2, Horizontal, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Horizontal, 3)
End Sub

'@TestMethod
Public Sub GivenAdjacentShipAtHorizontalTipEnd_ReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(10, 4)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 5, Vertical, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(6, 7), Horizontal, 4)
End Sub

'@TestMethod
Public Sub GivenAdjacentShipAtVerticalTipEnd_ReturnsTrue()
    Dim position As GridCoord
    Set position = GridCoord.Create(6, 7)

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 4, Horizontal, position)

    Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(10, 4), Vertical, 5)
End Sub

'@TestMethod
Public Sub GivenTwoSideBySideHits_GetHitAreaReturnsTwoItems()

    Const expected As Long = 2

    Dim sut As PlayerGrid
    Set sut = New PlayerGrid

    sut.AddShip Ship.Create("TEST", 5, Horizontal, GridCoord.Create(1, 1))
    sut.TryHit GridCoord.Create(1, 1)

    Dim actual As Long
    actual = sut.GetHitArea(GridCoord.Create(1, 1)).Count

    Assert.AreEqual expected, actual
End Sub

---

These two classes are the foundation of the game (I'll upload the whole thing to GitHub once I have everything ready - here's a teaser video), and since I'm planning to make this project a model of a VBA project to demonstrate Rubberduck's features and debunk any "VBA can't do real OOP" once and for all, I want this to be as good as it gets.

Does anything stick out? Please be picky!

---

The Globals module is just a standard procedural module that exposes, well, the game's globals:

'@Folder("Battleship")
Option Explicit

Public Const GridSize As Byte = 10
Public Const ShipsPerGrid As Byte = 5

Public Const Delay As Long = 1200

Public Const ShipNameCarrier As String = "Aircraft Carrier"
Public Const ShipNameBattleship As String = "Battleship"
Public Const ShipNameSubmarine As String = "Submarine"
Public Const ShipNameCruiser As String = "Cruiser"
Public Const ShipNameDestroyer As String = "Destroyer"

Public Function GetDefaultShips() As Variant
    GetDefaultShips = Array( _
        GetDefaultCarrier, _
        GetDefaultBattleship, _
        GetDefaultSubmarine, _
        GetDefaultCruiser, _
        GetDefaultDestroyer)
End Function

Private Function GetDefaultCarrier() As IShip
    Set GetDefaultCarrier = Ship.Create(ShipNameCarrier, 5, Horizontal, GridCoord.Create(1, 1))
End Function

Private Function GetDefaultBattleship() As IShip
    Set GetDefaultBattleship = Ship.Create(ShipNameBattleship, 4, Horizontal, GridCoord.Create(1, 1))
End Function

Private Function GetDefaultSubmarine() As IShip
    Set GetDefaultSubmarine = Ship.Create(ShipNameSubmarine, 3, Horizontal, GridCoord.Create(1, 1))
End Function

Private Function GetDefaultCruiser() As IShip
    Set GetDefaultCruiser = Ship.Create(ShipNameCruiser, 3, Horizontal, GridCoord.Create(1, 1))
End Function

Private Function GetDefaultDestroyer() As IShip
    Set GetDefaultDestroyer = Ship.Create(ShipNameDestroyer, 2, Horizontal, GridCoord.Create(1, 1))
End Function

I'm not 100% convinced this is the best place to put the ship names and default ships.

Answer 1

Based on my first not too thorough read, this looks rather nice. I currently only have two points of critique.

The first point is the lack of explicit interfaces. I think both the PlayerGrid and the Grid Coordinatescould use an explicit interface, IGrid and IGridCoordimate say. While it may be reasonable to invent different grids, it might look odd at first to have an interface for IGridCoordinate. However, with the interface you can hide away the Create member that really should not be used by consuming code.

The second point concerns the globals. First, I think the grid size and ship count should really be injected into the PlayerGrid instead of referring to global constants. At some point in the future you might want to make them a setting. Second, I think the global functions really belong in an implementation of an IShipFactory or maybe IShipyard that can be injected into anything needing to generate new ships.