VBA - Parsed JSON as application state - Simple Guest House Room Reservation

Continuing the theme of mutable JSON documents, here in this post I illustrate how we can start to build an application that stores its state in a JSON document. One envisages this as the client side logic and when ready to save to a database one posts the new document to a web service that can either save the whole document to MongoDb or shred the details into tables on a relational database.

The application given below is a very simple room reservation program for a small guest house we three bedrooms. There is a customers collection, a rooms collection and a bookings collection. A booking has a 'foreign key' to both the customer and the room.

There is a test sub at the end TestAddCustomerAndBookings() which adds two customers and two room bookings and then prints out the JSON document after its modifications.

{
  "Customers": [
    {
      "lCustomerId": "1",
      "sName": "Mr White",
      "sAddress": "London"
    },
    {
      "lCustomerId": "2",
      "sName": "Mr Blue",
      "sAddress": "Ohio"
    }
  ],
  "Rooms": [
    {
      "lRoomId": 1,
      "sleeps": 1
    },
    {
      "lRoomId": 2,
      "sleeps": 2
    },
    {
      "lRoomId": 3,
      "sleeps": 3
    }
  ],
  "Bookings": [
    {
      "lBookingId": "1",
      "lCustomerId": "1",
      "lRoomId": "1",
      "dtFirstNight": "25/12/2018",
      "dtLastNight": "02/01/2019"
    },
    {
      "lBookingId": "2",
      "lCustomerId": "2",
      "lRoomId": "3",
      "dtFirstNight": "02/02/2018",
      "dtLastNight": "06/02/2018"
    }
  ]
}

Here is the code listing

Option Explicit

'* Tools->References
' MSScriptControl      Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
' Scripting            Microsoft Scripting Runtime     C:\Windows\SysWOW64\scrrun.dll
' MSXML2               Microsoft XML, v6.0             C:\Windows\SysWOW64\msxml6.dll

Private mfso As New Scripting.FileSystemObject

Private moRoot As Object

Private Function SC() As ScriptControl
    Static soSC As ScriptControl
    If soSC Is Nothing Then

        Set soSC = New ScriptControl
        soSC.Language = "JScript"

        soSC.AddCode "function deleteValueByKey(obj,keyName) { delete obj[keyName]; } "
        soSC.AddCode "function setValueByKey(obj,keyName, newValue) { obj[keyName]=newValue; } "
        soSC.AddCode "function enumKeysToMsDict(jsonObj,msDict) { for (var i in jsonObj) { msDict.Add(i,0); }  } "
        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_stringify(value, replacer,spacer) { return JSON.stringify(value, replacer,spacer); } "
        soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "

    End If
    Set SC = soSC
End Function

Private Function GetJavaScriptLibrary(ByVal sURL As String) As String

    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibrary = xHTTPRequest.responseText

End Function

Private Function DefaultApplicationState() As Object
    Const sDefaultApplicationState As String = "{""Customers"":[], " & _
        """Rooms"":[{""lRoomId"":1,""sleeps"":1},{""lRoomId"":2,""sleeps"":2}," & _
        "{""lRoomId"":3,""sleeps"":3}], " & _
        """Bookings"": []}"
    
    Set DefaultApplicationState = SC.Run("JSON_parse", sDefaultApplicationState)
    
End Function


Private Function AddRoomBooking(ByVal lCustomerId As Long, ByVal lRoomId As Long, ByVal dtFirstNight As Date, ByVal dtLastNight As Date) As Long

    Dim objBookings As Object
    Set objBookings = CallByName(moRoot, "Bookings", VbGet)
    
    Dim lBookingId As Long
    lBookingId = CallByName(objBookings, "length", VbGet) + 1
    
    'TODO write logic to avoid double-booking
    
    Dim objNewBooking As Object
    Set objNewBooking = SC.Run("JSON_parse", "{ ""lBookingId"":""" & lBookingId & """, ""lCustomerId"":""" & lCustomerId & """," & _
            """lRoomId"":""" & lRoomId & """,""dtFirstNight"":""" & dtFirstNight & """,""dtLastNight"":""" & dtLastNight & """}")
    
    Call CallByName(objBookings, "push", VbMethod, objNewBooking)
    
    AddRoomBooking = lBookingId
End Function


Private Function AddCustomer(ByVal sName As String, ByVal sAddress As String) As Long
    Dim objCustomers As Object
    Set objCustomers = CallByName(moRoot, "Customers", VbGet)
    
    '* TODO fins unique id for each
    Dim lCustomerId As Long
    lCustomerId = CallByName(objCustomers, "length", VbGet) + 1
    
    Dim objNewCustomer As Object
    Set objNewCustomer = SC.Run("JSON_parse", "{ ""lCustomerId"":""" & lCustomerId & """, " & _
                        """sName"":""" & sName & """,""sAddress"":""" & sAddress & """}")
    
    Call CallByName(objCustomers, "push", VbMethod, objNewCustomer)
    
    AddCustomer = lCustomerId
End Function

Private Sub TestAddCustomerAndBookings()
    'End
    Set moRoot = DefaultApplicationState
    
    Dim lCustomerId As Long
    lCustomerId = AddCustomer("Mr White", "London")
    AddRoomBooking lCustomerId, 1, #12/25/2018#, #1/2/2019#
    
    lCustomerId = AddCustomer("Mr Blue", "Ohio")
    AddRoomBooking lCustomerId, 3, #2/2/2018#, #2/6/2018#
    
    Dim sAppStateSavePoint As String
    sAppStateSavePoint = SC.Run("JSON_stringify", moRoot, Null, 2)
    
    Debug.Print "'*TODO save either (a) as whole document to MondgoDb"
    Debug.Print "'* or (b) shred into tables on relational database"
    Debug.Print sAppStateSavePoint
    
End Sub