Web Battleship -The Unofficial Battleship UI

Question

I've written my own UI for Mathieu Guindon's VBA Battleship (Battleship UI: GameSheet) which uses a webpage in a WebBrowser control for the View.

Webform: Userform

Displays the webpage in a Webbrower control.

Private controller As GameController

Private Sub UserForm_Initialize()
    Dim View As WebView
    Set View = New WebView
    View.Init Me.WebBrowser1
    
    Dim randomizer As IRandomizer
    Set randomizer = New GameRandomizer
    
    Set controller = New GameController
    controller.NewGame GridViewAdapter.Create(View), randomizer
End Sub

Private Sub UserForm_Terminate()
    Set controller = Nothing
End Sub

WebElementListener: Class

Monitors the Click, Right Click, and Double Click events of a HMTLElement. It raises its own corresponding event when a HMTLElement event fires and relays to to a WebGroupListener, if applicable.

Attribute VB_Name = "WebElementListener"
Attribute VB_PredeclaredId = True
Option Explicit
'@Folder("Battleship.WebUI.Listeners")
Private WithEvents GenericElement As HTMLGenericElement
Attribute GenericElement.VB_VarHelpID = -1
Private WithEvents TableCell As HTMLTableCell
Attribute TableCell.VB_VarHelpID = -1

Private Type Members
    ID As String
    listener As WebGroupListener
End Type

Private this As Members

Public Event onClick(Element As HTMLGenericElement)
Public Event onDoubleClick(Element As HTMLGenericElement)
Public Event onRightClick(Element As HTMLGenericElement)

Public Function Create(newElement As Variant, Optional newListener As WebGroupListener) As WebElementListener
    With New WebElementListener
        .Object = newElement
        .listener = newListener
        Set Create = .Self
    End With
End Function

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

Public Sub Rotate(degrees As Long)
    Object.Style.cssText = "-ms-transform:rotate(" & degrees & "deg)"
End Sub

Public Property Get Object() As HTMLGenericElement
    Select Case True
        Case Not GenericElement Is Nothing
            Set Object = GenericElement
        Case Not TableCell Is Nothing
            Set Object = TableCell
    End Select
End Property

Public Property Let Object(ByVal Value As HTMLGenericElement)
    Select Case TypeName(Value)
        Case "HTMLTableCell"
            Set TableCell = Value
        Case Else
            Set GenericElement = Value
    End Select
End Property

Private Function GenericElement_onclick() As Boolean
    RaiseEvent onClick(Object)
    If Not listener Is Nothing Then listener.onClick Object
    GenericElement_onclick = True
End Function

Private Function GenericElement_oncontextmenu() As Boolean
    RaiseEvent onRightClick(Object)
    If Not listener Is Nothing Then listener.onRightClick Object
    GenericElement_oncontextmenu = False
End Function

Private Function GenericElement_ondblclick() As Boolean
    RaiseEvent onDoubleClick(Object)
    If Not listener Is Nothing Then listener.onDoubleClick Object
    GenericElement_ondblclick = True
End Function

Public Property Get listener() As WebGroupListener
    Set listener = this.listener
End Property

Private Function TableCell_onclick() As Boolean
    RaiseEvent onClick(Object)
    If Not listener Is Nothing Then listener.onClick Object
    TableCell_onclick = True
End Function

Private Function TableCell_oncontextmenu() As Boolean
    RaiseEvent onRightClick(Object)
    If Not listener Is Nothing Then listener.onRightClick Object
    TableCell_oncontextmenu = False
End Function

Private Function TableCell_ondblclick() As Boolean
    RaiseEvent onDoubleClick(Object)
    If Not listener Is Nothing Then listener.onDoubleClick Object
    TableCell_ondblclick = True
End Function

Public Property Let listener(ByVal Value As WebGroupListener)
    Set this.listener = Value
End Property

Public Property Get Visible() As Boolean
    Visible = Object.Style.display = "block"
End Property

Public Property Let Visible(ByVal Value As Boolean)
    Object.Style.display = IIf(Value, "block", "none")
End Property

WebGroupListener: Class

Monitors the Click, Right Click, and Double Click events of a WebElementListener. It raises its own corresponding event when a WebElementListener event fires and relays to to a WebGridGroup, if applicable.

Option Explicit
'@Folder("Battleship.WebUI.Listeners")
Public Elements As New Dictionary
Public Event onClick(Element As HTMLGenericElement)
Public Event onDoubleClick(Element As HTMLGenericElement)
Public Event onRightClick(Element As HTMLGenericElement)
Public EnableEvents As Boolean

Public Sub AddElement(key As Variant, ElementItem As Variant)
    Elements.Add key, WebElementListener.Create(ElementItem, Self)
End Sub

Public Sub onClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onClick(Element)
End Sub

Public Sub onDoubleClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onDoubleClick(Element)
End Sub

Public Sub onRightClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onRightClick(Element)
End Sub

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

Private Sub Class_Initialize()
    EnableEvents = True
End Sub

WebGroupListener: Class

Relays the Click, Right Click, and Double Click events of a WebGroupListener.

'@Folder("Battleship.WebUI.Listeners")
Public WithEvents TableGrid1 As WebGroupListener
Attribute TableGrid1.VB_VarHelpID = -1
Public WithEvents TableGrid2 As WebGroupListener
Attribute TableGrid2.VB_VarHelpID = -1

Public Event onClick(Element As HTMLGenericElement)
Public Event onDoubleClick(Element As HTMLGenericElement)
Public Event onRightClick(Element As HTMLGenericElement)
Public EnableEvents As Boolean

Private Sub Class_Initialize()
    Set TableGrid1 = New WebGroupListener
    Set TableGrid2 = New WebGroupListener
    EnableEvents = True
End Sub

Public Sub onClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onClick(Element)
End Sub

Public Sub onDoubleClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onDoubleClick(Element)
End Sub

Public Sub onRightClick(Element As HTMLGenericElement)
    If EnableEvents Then RaiseEvent onRightClick(Element)
End Sub

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

Private Sub TableGrid1_onClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onClick(Element)
End Sub

Private Sub TableGrid1_onDoubleClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onDoubleClick(Element)
End Sub

Private Sub TableGrid1_onRightClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onRightClick(Element)
End Sub

Private Sub TableGrid2_onClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onClick(Element)
End Sub

Private Sub TableGrid2_onDoubleClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onDoubleClick(Element)
End Sub

Private Sub TableGrid2_onRightClick(Element As MSHTML.HTMLGenericElement)
    If EnableEvents Then RaiseEvent onRightClick(Element)
End Sub

WebFlashElement: Class

Flashes an HTMLDivElement element

Option Explicit
'@Folder("Battleship.WebUI.Shapes")
Private WithEvents TargetElement As HTMLDivElement
Attribute TargetElement.VB_VarHelpID = -1
Private mREADYSTATE As tagREADYSTATE

Public Function Create(newElement As HTMLDivElement) As WebFlashElement
    With New WebFlashElement
        .Element = newElement
        Set Create = .Self
    End With
End Function

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

Public Property Get Element() As HTMLDivElement
    Set Element = TargetElement
End Property

Public Property Let Element(ByVal Value As HTMLDivElement)
    Set TargetElement = Value
End Property

Sub FlashShape(td As HTMLTableCell, ByVal flashes As Long, Optional ByVal Delay As Long = 50)
    If mREADYSTATE <> READYSTATE_COMPLETE Then Exit Sub
    mREADYSTATE = READYSTATE_LOADING
    Dim Left As Double, Top As Double
    Dim rect As IHTMLRect
    Set rect = td.getBoundingClientRect

    Left = rect.Left - TargetElement.offsetWidth / 2 - rect.Width
    Top = rect.Top - TargetElement.offsetHeight / 2 - rect.Height
    
    If Left < 0 Then Left = rect.Left
    If Top < 0 Then Top = rect.Top

    Dim i As Long, n As Long
    For i = 0 To flashes - 1
        With GameRandomizer
            n = CInt(GameRandomizer.NextSingle * 30) - 15
        End With
        
        TargetElement.Style.cssText = "-ms-transform:rotate(" & n & "deg)"
        TargetElement.Style.Left = Left & "px"
        TargetElement.Style.Top = Top & "px"
        TargetElement.Style.display = "block"
        DoEvents
        Sleep Delay * 1.5
        
        TargetElement.Style.display = "none"
        DoEvents
        Sleep Delay * 0.75
    Next

    TargetElement.Style.display = "block"
    DoEvents
    Sleep Delay * 2
    TargetElement.Style.display = "none"
    
    DoEvents
    mREADYSTATE = READYSTATE_COMPLETE
End Sub

Public Property Get READYSTATE() As tagREADYSTATE
    READYSTATE = mREADYSTATE
End Property

Private Sub Class_Initialize()
    mREADYSTATE = READYSTATE_COMPLETE
End Sub

WebView: Class

Interacts with the Gamecontroller to control the webpage.

Option Explicit
'@Folder("Battleship.WebUI")
Implements IGridViewCommands
Private Const InfoBoxMessage As String = _
        "ENEMY FLEET DETECTED" & vbNewLine & _
        "ALL SYSTEMS READY" & vbNewLine & vbNewLine & _
        "DOUBLE CLICK IN THE ENEMY Grid TO FIRE A MISSILE." & vbNewLine & vbNewLine & _
        "FIND AND DESTROY ALL ENEMY SHIPS BEFORE THEY DESTROY YOUR OWN FLEET!"

Private Const InfoBoxPlaceSHIPs As String = _
        "FLEET DEPLOYMENT" & "<BR>" & _
        "ACTION REQUIRED:" & "<BR>" & _
        "DEPLOY %SHIP%" & "<BR>" & _
        " -CLICK TO PREVIEW" & "<BR>" & _
        " -RIGHT CLICK TO ROTATE" & "<BR>" & _
        " -DOUBLE CLICK TO CONFIRM"

Private Const ErrorBoxInvalidPosition As String = _
        "FLEET DEPLOYMENT" & vbNewLine & _
        "SYSTEM ERROR" & vbNewLine & vbNewLine & _
        " -SHIPS CANNOT OVERLAP." & vbNewLine & _
        " -SHIPS MUST BE ENTIRELY WITHIN THE Grid." & vbNewLine & vbNewLine & _
        "DEPLOY SHIP TO ANOTHER POSITION."

Private Const ErrorBoxInvalidKnownAttackPosition As String = _
        "TARGETING SYSTEM" & vbNewLine & vbNewLine & _
        "SPECIFIED Grid LOCATION IS ALREADY IN A KNOWN STATE." & vbNewLine & vbNewLine & _
        "NEW VALID COORDINATES REQUIRED."

Private Const DebugMode As Boolean = True

Private Type Members
    ActiveGridID As Byte
    Adapter As IWeakReference
    currentPosition As GridCoord
    GridCells As New Dictionary
    Fleets(1 To 2) As New Dictionary
    HumanID As Byte
    IE As SHDocVw.InternetExplorerMedium
    PrimaryID As Byte
    HumanFleet As Collection
    PreviousMode As ViewMode
    Mode As ViewMode
    ShipHitAreas(1 To 2) As New Dictionary
End Type

Private this As Members

Private Type TFlashBoxes
    HitGrid As WebFlashElement
    MissLabelGrid As WebFlashElement
    SunkGrid As WebFlashElement
End Type

Private flashBoxes As TFlashBoxes

Private WithEvents Document As HTMLDocument
Attribute Document.VB_VarHelpID = -1
Private WithEvents WebGrid As WebGridGroup
Attribute WebGrid.VB_VarHelpID = -1
Private WithEvents StrategyButtonGroup1 As WebGroupListener
Attribute StrategyButtonGroup1.VB_VarHelpID = -1
Private WithEvents StrategyButtonGroup2 As WebGroupListener
Attribute StrategyButtonGroup2.VB_VarHelpID = -1
Private WithEvents ErrorBox As HTMLDivElement
Attribute ErrorBox.VB_VarHelpID = -1
Private WithEvents Informationbox As HTMLDivElement
Attribute Informationbox.VB_VarHelpID = -1
Private WithEvents GameOverLoseGrid As HTMLDivElement
Attribute GameOverLoseGrid.VB_VarHelpID = -1
Private WithEvents GameOverWinGrid As HTMLDivElement
Attribute GameOverWinGrid.VB_VarHelpID = -1
Private PlayerNameDiv As HTMLDivElement
Private WithEvents btnPlayerNameOK As HTMLInputElement
Attribute btnPlayerNameOK.VB_VarHelpID = -1
Private txtPlayerName As HTMLInputElement

Public Sub Init(IE As SHDocVw.InternetExplorerMedium)
    Set this.IE = IE
End Sub

Public Sub ClearGrid(ByVal GridID As Byte)
    Dim TableGrid As WebGroupListener
    Set TableGrid = IIf(GridID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)

    Dim n As Long, listener As WebElementListener
    For n = 0 To TableGrid.Elements.Count - 1
        Set listener = TableGrid.Elements.Items(n)
        listener.Object.className = ""
    Next
End Sub

Private Function btnPlayerNameOK_onclick() As Boolean
    PlayerNameDiv.Style.display = "none"
    ViewEvents.CreatePlayer this.HumanID, HumanControlled, AIDifficulty.Unspecified
    btnPlayerNameOK_onclick = True
End Function

Private Function ErrorBox_onclick() As Boolean
    setErrorBox "", False
End Function

Private Sub FlashBoxFlash(FlashBox As WebFlashElement, ByVal GridID As Byte)
    Dim td As HTMLTableCell, TableGrid As WebGroupListener
    Set TableGrid = IIf(GridID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)
    Set td = TableGrid.Elements.item(this.currentPosition.ToString).Object
    With GameRandomizer
        FlashBox.FlashShape td, IIf(.NextSingle < 0.75, 1, IIf(.NextSingle < 0.75, 3, 4))
    End With
    While FlashBox.READYSTATE <> READYSTATE_COMPLETE: DoEvents: Wend
End Sub

Private Function getBattleShipURL() As String
    Dim Path As String
    Path = Split(ThisWorkbook.Path, ":")(1)
    Path = Replace(Path, "\", "/")
    getBattleShipURL = "file://127.0.0.1/c$" & Path & "/index.html"
End Function

Private Function getCaption(GridID As Byte) As HTMLTableCaption
    Set getCaption = Document.getElementById("Grid" & GridID).getElementsByTagName("caption").item(0)
End Function

Private Function getCurrentHumanPlayerGrid() As WebGroupListener
    If this.Mode = ViewMode.FleetPosition Then
        Set getCurrentHumanPlayerGrid = IIf(this.PrimaryID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)
    Else
        Set getCurrentHumanPlayerGrid = IIf(this.PrimaryID = 2, WebGrid.TableGrid1, WebGrid.TableGrid2)
    End If
End Function

Private Function getShipDiv(ShipName As String, GridID As Byte) As HTMLDivElement
    ShipName = Replace(ShipName, " ", "") & GridID
    Set getShipDiv = Document.getElementById(ShipName)
End Function

Private Function getTargetShipDiv(ShipName As String, GridID As Byte, Optional isSunken As Boolean) As HTMLDivElement
    ShipName = "Target-" & Replace(ShipName, " ", "") & GridID
    Set getTargetShipDiv = Document.getElementById(ShipName)
    If isSunken Then getTargetShipDiv.getElementsByTagName("div").item(0).Style.display = "block"
End Function

Private Function Informationbox_onclick() As Boolean
    this.Mode = this.PreviousMode
    ViewEvents.HumanPlayerReady
    Informationbox.Style.display = "none"
End Function

Private Sub InitGrid(GridID As Byte)
    Dim group As New WebGroupListener
    Dim tbody As HTMLTableSection, td As HTMLTableCell, tr As HTMLTableRow
    Set tbody = Document.getElementById("Grid" & GridID).getElementsByTagName("tbody").item(0)

    Dim X As Long
    Dim Y As Long
    Dim key As Variant
    For Y = 1 To tbody.Rows.Length - 1
        Set tr = tbody.Rows(Y)
        For X = 1 To tr.Cells.Length - 1
            Set td = tr.Cells.item(X)
            key = GridCoord.Create(X, Y).ToString
            group.AddElement key, td
        Next
    Next
    If GridID = 1 Then Set WebGrid.TableGrid1 = group Else Set WebGrid.TableGrid2 = group
End Sub

Private Sub InitPrimaryID(GridID As Byte)
    Const EnemyShip As String = " bg-Enemy-", PrimaryShip As String = " bg-"
    this.PrimaryID = GridID
    'Display Acquired Target and Fleet Position Boxes
    With Document.getElementsByClassName("TargetsBox")
        .item(IIf(this.PrimaryID = 1, 1, 0)).className = "TargetsBox acquired-targets"
        .item(0).Style.display = "block"
        .item(1).Style.display = "block"
    End With
    
    'Add Ship Classes to Fleet Position Box Divs
    Dim n As Long
    For n = 0 To UBound(Ship.Names)
        With getTargetShipDiv(CStr(Ship.Names(n)), this.PrimaryID)
            .className = .className & PrimaryShip & Replace(Ship.Names(n), " ", "")
        End With
        
        With getTargetShipDiv(CStr(Ship.Names(n)), IIf(this.PrimaryID = 1, 2, 1))
            .className = .className & EnemyShip & Replace(Ship.Names(n), " ", "")
        End With
    Next
End Sub

Private Sub InitPrimaryShips(GridID As Byte, ShipSuffix As Byte, Fleet As Collection)
'Show Table Ships
    Dim currentShip As IShip, ShipName As String
    Dim td As HTMLTableCell, ShipDiv As HTMLDivElement
    Dim TableGrid As WebGroupListener
    Set TableGrid = IIf(GridID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)

    For Each currentShip In Fleet
        ShipName = Replace(currentShip.name, " ", "") & ShipSuffix
        Set ShipDiv = Document.getElementById(ShipName)
        Set td = TableGrid.Elements.item(GridCoord.Create(currentShip.GridPosition.X, currentShip.GridPosition.Y).ToString).Object

        Dim PaddingLeft As Double, PaddingTop As Double

        SnapToTableCell ShipDiv, td, currentShip.Orientation

        this.Fleets(GridID).Add currentShip.name, ShipDiv

        Dim n As Long, X As Long, Y As Long
        Dim hitArea As HTMLDivElement, hitCood As GridCoord
        With currentShip
            X = .GridPosition.X
            Y = .GridPosition.Y
            For n = 0 To .Size - 1
                Set hitArea = ShipDiv.getElementsByTagName("div").item(n)
                Set hitCood = GridCoord.Create(IIf(.Orientation = Horizontal, X + n, X), IIf(.Orientation = Vertical, Y + n, Y))
                this.ShipHitAreas(GridID).Add hitCood.ToString, hitArea
            Next
        End With
    Next
End Sub

Private Sub InitStrategyButtonGroup(GridID As Byte)
    Dim group As New WebGroupListener
    Dim div As HTMLDivElement
    Dim n As Long
    Set div = Document.getElementsByClassName("strategy").item(GridID - 1)
    For n = 0 To 3
        group.AddElement n, div.getElementsByTagName("div").item(n)
    Next
    If GridID = 1 Then Set StrategyButtonGroup1 = group Else Set StrategyButtonGroup2 = group
End Sub

Public Sub RefreshGrid(ByVal Grid As PlayerGrid)
    Dim state As Variant, X As Long, Y As Long
    Dim td As HTMLTableCell, listener As WebElementListener, key As Variant, className As String, group As WebGroupListener

    Set group = IIf(Grid.GridID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)

    For X = 1 To Grid.Size
        For Y = 1 To Grid.Size
            key = GridCoord.Create(X, Y).ToString
            state = Grid.StateArray(X, Y)
            className = Switch(IsEmpty(state), "", _
                               state = GridState.Unknown, "", _
                               state = GridState.InvalidPosition, "InvalidPosition", _
                               state = GridState.PreviewShipPosition, "PreviewShipPosition", _
                               state = GridState.ShipPosition, "ShipPosition", _
                               state = GridState.PreviousMiss, "PreviousMiss", _
                               state = GridState.InvalidPosition, "InvalidPosition", _
                               state = GridState.PreviousHit, "PreviousHit")

            If this.PrimaryID = Grid.GridID And this.ShipHitAreas(Grid.GridID).Exists(key) And className = "PreviousHit" Then
                this.ShipHitAreas(Grid.GridID).item(key).Style.display = "block"
                className = ""
            End If
            Set listener = group.Elements.item(key)
            Set td = listener.Object
            td.className = className
        Next
    Next
    DoEvents
End Sub

Private Sub setErrorBox(Message As String, Show As Boolean)
    If Show Then
        this.PreviousMode = this.Mode
        this.Mode = MessageShown
        ErrorBox.innerText = Message
        ErrorBox.Style.display = "block"
    Else
        this.Mode = this.PreviousMode
        ErrorBox.Style.display = "none"
    End If
End Sub

Private Sub SnapToTableCell(target As HTMLDivElement, td As HTMLTableCell, Orientation As ShipOrientation)
    Dim Left As Double, Top As Double
    Dim rect As IHTMLRect
    Set rect = td.getBoundingClientRect

    target.Style.cssText = ""
    target.Style.display = "block"

    If Orientation = Horizontal Then
        Left = rect.Left
        Top = rect.Top
    Else
        target.Style.cssText = "-ms-transform:rotate(90deg)"
        target.Style.display = "block"
        Left = rect.Left - target.offsetWidth / 2 + rect.Width / 2
        Top = rect.Top + target.offsetWidth / 2 - rect.Width / 2 + 3
    End If
    DoEvents
    target.Style.Left = Left & "px"
    target.Style.Top = Top & "px"
End Sub

Private Sub StrategyButtonGroup1_onClick(Element As MSHTML.HTMLGenericElement)
    StrategyButtonGroupClicked Element, 1, StrategyButtonGroup1
End Sub

Private Sub StrategyButtonGroup2_onClick(Element As MSHTML.HTMLGenericElement)
    StrategyButtonGroupClicked Element, 2, StrategyButtonGroup2
End Sub

Private Sub StrategyButtonGroupClicked(Element As MSHTML.HTMLGenericElement, GridID As Byte, group As WebGroupListener)
    Dim item As Variant

    For Each item In group.Elements.Items
        item.Visible = False
    Next

    Select Case Element.getAttribute("type")
        Case "Human"
            IIf(GridID = 1, StrategyButtonGroup2.Elements.Items(0), StrategyButtonGroup1.Elements.Items(0)).Visible = False
            this.HumanID = GridID
            PlayerNameDiv.Style.display = "block"
            txtPlayerName.Focus
        Case "FairplayAI"
            getCaption(GridID).innerHTML = "FairplayAI"
            ViewEvents.CreatePlayer GridID, ComputerControlled, AIDifficulty.FairplayAI
        Case "RandomAI"
            getCaption(GridID).innerHTML = "RandomAI"
            ViewEvents.CreatePlayer GridID, ComputerControlled, AIDifficulty.RandomAI
        Case "MercilessAI"
            getCaption(GridID).innerHTML = "MercilessAI"
            ViewEvents.CreatePlayer GridID, ComputerControlled, AIDifficulty.MercilessAI
    End Select

    DoEvents
End Sub

Private Sub WebGrid_onClick(Element As MSHTML.HTMLGenericElement)
    Dim position As GridCoord
    Set position = GridCoord.Create(Element.cellIndex, Element.parentElement.RowIndex)
    If this.Mode = ViewMode.FleetPosition Then
        ViewEvents.PreviewShipPosition this.PrimaryID, position
    End If
End Sub

Private Sub WebGrid_onDoubleClick(Element As MSHTML.HTMLGenericElement)
    Dim position As GridCoord
    Set position = GridCoord.Create(Element.cellIndex, Element.parentElement.RowIndex)
    If this.Mode = ViewMode.FleetPosition Then
        ViewEvents.ConfirmShipPosition this.PrimaryID, position
    ElseIf this.Mode = IIf(this.PrimaryID = 1, ViewMode.player1, ViewMode.player2) Then
        ViewEvents.AttackPosition IIf(this.PrimaryID = 1, 2, 1), position
    End If
End Sub

Private Sub WebGrid_onRightClick(Element As MSHTML.HTMLGenericElement)
    Dim position As GridCoord
    Set position = GridCoord.Create(Element.cellIndex, Element.parentElement.RowIndex)
    If this.Mode = ViewMode.FleetPosition Then
        ViewEvents.PreviewRotateShip this.PrimaryID, position
    End If
End Sub

Private Property Get ViewEvents() As IGridViewEvents
    Set ViewEvents = this.Adapter.Object
End Property

':IGridViewCommands
':Messages sent from the controller
':*********************************

Private Property Set IGridViewCommands_Events(ByVal Value As IGridViewEvents)
    Set this.Adapter = WeakReference.Create(Value)
End Property

Private Property Get IGridViewCommands_Events() As IGridViewEvents
    Set IGridViewCommands_Events = this.Adapter.Object
End Property

Private Sub IGridViewCommands_OnBeginAttack(ByVal currentPlayerGridId As Byte)
    ClearGrid this.PrimaryID
    InitPrimaryShips this.PrimaryID, 1, this.HumanFleet
End Sub

'Automatically Confirm Ship Position
Private Sub IGridViewCommands_OnBeginShipPosition(ByVal currentShip As IShip, ByVal player As IPlayer)
    If this.PrimaryID = 0 Then
        InitPrimaryID player.PlayGrid.GridID
        this.Mode = FleetPosition
    End If
    
    'Display Deployment Message in Table Caption Marquee
    getCaption(this.PrimaryID).innerHTML = "<marquee behavior=scroll direction='up' scrollamount='3' style='font-size:14px;'>" & Replace(InfoBoxPlaceSHIPs, "%SHIP%", "<span style='color:white;'>" & UCase$(currentShip.name) & "</span>") & "<marquee>"

    'Show Deployed Ship
    getTargetShipDiv(currentShip.name, this.PrimaryID).Style.display = "block"
End Sub

Private Sub IGridViewCommands_OnBeginWaitForComputerPlayer()
    If Not DebugMode Then
        Application.Cursor = xlWait
        Application.StatusBar = "Please wait..."
    End If
End Sub

Private Sub IGridViewCommands_OnEndWaitForComputerPlayer()
    Application.Cursor = xlDefault
    Application.StatusBar = False
End Sub

Private Sub IGridViewCommands_OnConfirmShipPosition(ByVal player As IPlayer, ByVal newShip As IShip)
    If player.PlayGrid.Fleet.Count = Ship.Fleet.Count Then
        getCaption(this.PrimaryID).innerText = txtPlayerName.Value
        Set this.HumanFleet = player.PlayGrid.Fleet
        this.PreviousMode = ViewMode.player1
        this.Mode = MessageShown
        Informationbox.innerText = InfoBoxMessage
        Informationbox.Style.display = "block"
    End If
End Sub

Private Sub IGridViewCommands_OnGameOver(ByVal winningGridId As Byte)
    this.Mode = ViewMode.GameOver

    Dim td As HTMLTableCell
    Dim TableGrid As WebGroupListener
    Set TableGrid = IIf(winningGridId = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)
    SnapToTableCell GameOverWinGrid, TableGrid.Elements.item("(4,3)").Object, Horizontal

    Set TableGrid = IIf(winningGridId = 2, WebGrid.TableGrid1, WebGrid.TableGrid2)
    SnapToTableCell GameOverLoseGrid, TableGrid.Elements.item("(4,3)").Object, Horizontal
End Sub

Private Sub IGridViewCommands_OnHit(ByVal GridID As Byte)
    FlashBoxFlash flashBoxes.HitGrid, GridID
End Sub

Private Sub IGridViewCommands_OnInvalidShipPosition()
    setErrorBox ErrorBoxInvalidPosition, True
End Sub

Private Sub IGridViewCommands_OnKnownPositionAttack(): End Sub

Private Sub IGridViewCommands_OnLockGrid(ByVal GridID As Byte): End Sub

Private Sub IGridViewCommands_OnMiss(ByVal GridID As Byte)
    FlashBoxFlash flashBoxes.MissLabelGrid, GridID
End Sub

Private Sub IGridViewCommands_OnNewGame()
    this.Mode = ViewMode.NewGame
    With this.IE
        .Silent = True
        If Len(.LocationURL) = 0 Then
            .Navigate getBattleShipURL
        Else
            .Refresh
        End If
        While .Busy Or .READYSTATE <> READYSTATE_COMPLETE: DoEvents: Wend
        Set Document = .Document
    End With

    'Initiate StrategyButtonGroups
    InitStrategyButtonGroup 1
    InitStrategyButtonGroup 2

    'Initiate WebGridGroup
    Set WebGrid = New WebGridGroup
    InitGrid 1
    InitGrid 2

    'Initiate Message Boxes
    Set ErrorBox = Document.getElementById("ErrorBox")
    Set Informationbox = Document.getElementById("informationbox")
    Set GameOverLoseGrid = Document.getElementById("GameOverLoseGrid")
    Set GameOverWinGrid = Document.getElementById("GameOverWinGrid")
    Set PlayerNameDiv = Document.getElementById("PlayerName")
    Set btnPlayerNameOK = Document.getElementById("btnPlayerNameOK")
    Set txtPlayerName = Document.getElementById("txtPlayerName")

    'Initiate Flash Boxes
    Set flashBoxes.HitGrid = WebFlashElement.Create(Document.getElementById("HitGrid"))
    Set flashBoxes.MissLabelGrid = WebFlashElement.Create(Document.getElementById("MissLabelGrid"))
    Set flashBoxes.SunkGrid = WebFlashElement.Create(Document.getElementById("SunkGrid"))
End Sub

Private Sub IGridViewCommands_OnPreviewShipPosition(ByVal player As IPlayer, ByVal newShip As IShip)
    RefreshGrid player.PlayGrid
    Debug.Assert Not newShip Is Nothing
    Dim n As Long, X As Long, Y As Long
    Dim td As HTMLTableCell, listener As WebElementListener, key As Variant, className As String, group As WebGroupListener

    Set group = IIf(player.PlayGrid.GridID = 1, WebGrid.TableGrid1, WebGrid.TableGrid2)

    With newShip
        X = .GridPosition.X
        Y = .GridPosition.Y
        For n = 0 To .Size - 1
            key = GridCoord.Create(X + IIf(.Orientation = Horizontal, n, 0), Y + IIf(.Orientation = Vertical, n, 0)).ToString
            Set listener = group.Elements.item(key)
            Set td = listener.Object

            className = IIf(Len(td.className) > 0, "InvalidPosition", "PreviewShipPosition")

            td.className = className
        Next
    End With
    DoEvents
End Sub

Private Sub IGridViewCommands_OnRefreshGrid(ByVal Grid As PlayerGrid)
    If this.PrimaryID = 0 Then InitPrimaryID 1
    RefreshGrid Grid
End Sub

Private Sub IGridViewCommands_OnSelectPosition(ByVal GridID As Byte, ByVal position As IGridCoord)
    Set this.currentPosition = position
    this.Mode = IIf(this.Mode = ViewMode.player1, ViewMode.player2, ViewMode.player1)
End Sub

Private Sub IGridViewCommands_OnSink(ByVal GridID As Byte)
    FlashBoxFlash flashBoxes.SunkGrid, GridID
End Sub

Private Sub IGridViewCommands_OnUpdateFleetStatus(ByVal player As IPlayer, ByVal hitShip As IShip, Optional ByVal showAIStatus As Boolean = False)
    If (player.PlayerType = ComputerControlled And showAIStatus) Or hitShip.isSunken Then
        getTargetShipDiv(hitShip.name, player.PlayGrid.GridID, hitShip.isSunken).Style.display = "block"
    End If
End Sub

Overall, I am pretty happy with the project but there are still a few issues to iron out:

• The game keeps running after the Webform is closed. I will probably have to add a Close event to the Webform to trigger the actual Webform variable to be destroyed.

• Create a New Game button to restart the game

• Display the attack position coordinates.

• Run the UI in an actual IE Browser. Currently, the code will run but IE will not repaint the page after the second player is created. The page is updated when the game is over. DoEvents is used to allow the Webbrowser control to update but has no effect on IE. I have tried a myriad of jank solutions from my research to no avail.

I got a little sloppy towards the end. There are a few methods in my classes are no longer being used. I'm going to leave them for now.

Download Web Battleship -The Unofficial Battleship UI

Mathieu Guindon's original VBA Battleship file on GitHub