Attribute VB_Name = "ExsitecDataLink"
Option Explicit

Public Const NXT_ERR_NOT_RUNNING As Long = vbObjectError + 2301
Public Const NXT_ERR_NOT_SIGNED_IN As Long = vbObjectError + 2302
Public Const NXT_ERR_FORBIDDEN As Long = vbObjectError + 2303
Public Const NXT_ERR_INVALID As Long = vbObjectError + 2304
Public Const NXT_ERR_NXT As Long = vbObjectError + 2305
Public Const NXT_ERR_UNAVAILABLE As Long = vbObjectError + 2306
Public Const NXT_ERR_OTHER As Long = vbObjectError + 2307

Public NxtSilent As Boolean

Private Const HDR_API_KEY As String = "X-DataLink-Key"
Private Const HDR_INSTANCE As String = "X-DataLink-Instance"
Private Const STATUS_PATH As String = "/v1/status"
Private Const LOGIN_PATH As String = "/v1/auth/login"
Private Const GRAPHQL_PATH As String = "/v1/nxt/graphql"
Private Const DISCOVERY_SUFFIX As String = "\Exsitec\DataLink\endpoint.json"
Private Const SETTINGS_SUFFIX As String = "\Exsitec\DataLink\ui-settings.json"
Private Const DOWNLOAD_URL As String = "https://ex-desktopdatalink-api-prod-bgcagmckbrg7h4dp.swedencentral-01.azurewebsites.net/"

Private mEndpointFile As String
Private mBaseUrl As String
Private mKey As String
Private mInstanceId As String
Private mLanguageOverride As String
Private mStartPath As String
Private mFallbackStartPath As String
Private mText As String
Private mPos As Long
Private mLen As Long

Public Function NxtQuery(ByVal gql As String, Optional ByVal vars As Object) As Object
    If Len(Trim$(gql)) = 0 Then Err.Raise NXT_ERR_INVALID, "ExsitecDataLink", Text("emptyQuery")
    Dim variables As Object
    If vars Is Nothing Then Set variables = NewDict() Else Set variables = vars
    If InStr(1, gql, "$company", vbTextCompare) > 0 Then
        If Not variables.Exists("company") Then variables("company") = CLng(COMPANY_NO)
    End If
    Dim status As Object
    Set status = EnsureReady()
    If Not IsAuthenticated(status) Then BeginSignInAndRaise
    Dim body As Object
    Set body = NewDict()
    body("query") = gql
    Set body("variables") = variables
    Dim http As Object
    Set http = SendWithRetry("POST", GRAPHQL_PATH, body, 600000, IsQueryDocument(gql))
    Dim response As Object
    Set response = ParseResponse(http)
    If http.Status < 200 Or http.Status >= 300 Then RaiseResponseError http.Status, response
    RaiseGraphQlErrors response
    If response.Exists("data") And IsObject(response("data")) Then
        Set NxtQuery = response("data")
    Else
        Set NxtQuery = NewDict()
    End If
End Function

Public Function NxtVars(ParamArray nameValuePairs() As Variant) As Object
    Dim result As Object
    Set result = NewDict()
    Dim first As Long, last As Long
    On Error GoTo Done
    first = LBound(nameValuePairs): last = UBound(nameValuePairs)
    On Error GoTo 0
    If ((last - first + 1) Mod 2) <> 0 Then Err.Raise NXT_ERR_INVALID, "ExsitecDataLink.NxtVars", Text("badVars")
    Dim i As Long
    For i = first To last Step 2
        If IsObject(nameValuePairs(i + 1)) Then Set result(CStr(nameValuePairs(i))) = nameValuePairs(i + 1) Else result(CStr(nameValuePairs(i))) = nameValuePairs(i + 1)
    Next i
Done:
    Set NxtVars = result
End Function

Public Function NxtItems(ByVal data As Object, ByVal path As String) As Collection
    Dim emptyItems As Collection
    Set emptyItems = New Collection
    If data Is Nothing Then Set NxtItems = emptyItems: Exit Function
    Dim node As Object
    Set node = data
    Dim parts() As String
    parts = Split(path, ".")
    Dim i As Long
    For i = 0 To UBound(parts)
        If TypeName(node) <> "Dictionary" Then Set NxtItems = emptyItems: Exit Function
        If Not node.Exists(parts(i)) Then Set NxtItems = emptyItems: Exit Function
        If Not IsObject(node(parts(i))) Then Set NxtItems = emptyItems: Exit Function
        Set node = node(parts(i))
    Next i
    If TypeName(node) = "Dictionary" And node.Exists("items") Then
        If IsObject(node("items")) And TypeName(node("items")) = "Collection" Then Set NxtItems = node("items") Else Set NxtItems = emptyItems
    Else
        Set NxtItems = emptyItems
    End If
End Function

Public Sub ShowNxtError()
    If Not NxtSilent Then MsgBox Err.Description, vbExclamation, "Exsitec Data Link"
End Sub

Public Sub NxtUseEndpointFile(ByVal path As String)
    mEndpointFile = path
    mBaseUrl = "": mKey = "": mInstanceId = ""
End Sub

Public Sub NxtUseLanguage(ByVal languageCode As String)
    mLanguageOverride = languageCode
End Sub

Public Sub NxtUseStartPaths(Optional ByVal primaryExe As String = "", Optional ByVal fallbackExe As String = "")
    mStartPath = primaryExe
    mFallbackStartPath = fallbackExe
End Sub

Private Function EnsureReady() As Object
    Dim status As Object
    Set status = TryGetStatus()
    If Not status Is Nothing Then Set EnsureReady = status: Exit Function
    StartDataLink
    Dim oldStatusBar As Variant
    oldStatusBar = SetStatusBar(Text("starting"))
    On Error GoTo Failed
    Dim started As Single
    started = Timer
    Do
        Set status = TryGetStatus()
        If Not status Is Nothing Then RestoreStatusBar oldStatusBar: Set EnsureReady = status: Exit Function
        DoEvents
        PauseSeconds 0.25
    Loop While Not Elapsed(started, 30)
Failed:
    RestoreStatusBar oldStatusBar
    Err.Raise NXT_ERR_NOT_RUNNING, "ExsitecDataLink", Text("notRunning") & " " & DOWNLOAD_URL
End Function

Private Function TryGetStatus() As Object
    On Error GoTo Failed
    Discover
    Dim http As Object
    Set http = SendOnce("GET", STATUS_PATH, Empty, 30000)
    If http Is Nothing Then GoTo Failed
    If http.Status < 200 Or http.Status >= 300 Then GoTo Failed
    Set TryGetStatus = ParseResponse(http)
    Exit Function
Failed:
    Set TryGetStatus = Nothing
End Function

Private Sub StartDataLink()
    Dim primary As String, fallback As String
    If Len(mStartPath) > 0 Or Len(mFallbackStartPath) > 0 Then
        primary = mStartPath: fallback = mFallbackStartPath
    Else
        primary = Environ$("LOCALAPPDATA") & "\Exsitec.DataLink\Exsitec Data Link.exe"
        fallback = Environ$("LOCALAPPDATA") & "\Exsitec.DataLink\current\DesktopDataLink.Host.exe"
    End If
    Dim path As String
    path = ExistingFile(primary)
    If Len(path) = 0 Then path = ExistingFile(fallback)
    If Len(path) = 0 Then Err.Raise NXT_ERR_NOT_RUNNING, "ExsitecDataLink", Text("notRunning") & " " & DOWNLOAD_URL
    On Error GoTo Failed
    CreateObject("WScript.Shell").Run """" & path & """", 0, False
    Exit Sub
Failed:
    Err.Raise NXT_ERR_NOT_RUNNING, "ExsitecDataLink", Text("notRunning") & " " & DOWNLOAD_URL
End Sub

Private Function ExistingFile(ByVal path As String) As String
    If Len(path) > 0 Then If CreateObject("Scripting.FileSystemObject").FileExists(path) Then ExistingFile = path
End Function

Private Sub BeginSignInAndRaise()
    If NxtSilent Then Err.Raise NXT_ERR_NOT_SIGNED_IN, "ExsitecDataLink", Text("signInCanceled")
    If MsgBox(Text("signInPrompt"), vbOKCancel + vbInformation, "Exsitec Data Link") <> vbOK Then _
        Err.Raise NXT_ERR_NOT_SIGNED_IN, "ExsitecDataLink", Text("signInCanceled")
    Dim oldStatusBar As Variant
    oldStatusBar = SetStatusBar(Text("signingIn"))
    On Error Resume Next
    SendWithRetry "POST", LOGIN_PATH, Empty, 330000, False
    On Error GoTo 0
    RestoreStatusBar oldStatusBar
    Err.Raise NXT_ERR_NOT_SIGNED_IN, "ExsitecDataLink", Text("signInAgain")
End Sub

Private Function SendWithRetry(ByVal method As String, ByVal path As String, ByVal body As Variant, ByVal receiveTimeoutMs As Long, ByVal allowRetry As Boolean) As Object
    Discover
    Dim http As Object
    Set http = SendOnce(method, path, body, receiveTimeoutMs)
    If http Is Nothing And allowRetry Then Discover: Set http = SendOnce(method, path, body, receiveTimeoutMs)
    If http Is Nothing Then Err.Raise NXT_ERR_UNAVAILABLE, "ExsitecDataLink", Text("unavailable")
    CaptureInstance http
    Set SendWithRetry = http
End Function

Private Function SendOnce(ByVal method As String, ByVal path As String, ByVal body As Variant, ByVal receiveTimeoutMs As Long) As Object
    On Error GoTo Failed
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open method, mBaseUrl & path, False
    http.SetTimeouts 5000, 5000, 30000, receiveTimeoutMs
    http.SetRequestHeader HDR_API_KEY, mKey
    If IsObject(body) Then
        http.SetRequestHeader "Content-Type", "application/json"
        http.Send Stringify(body)
    ElseIf VarType(body) = vbString Then
        If Len(CStr(body)) > 0 Then http.SetRequestHeader "Content-Type", "application/json"
        http.Send CStr(body)
    Else
        http.Send
    End If
    Set SendOnce = http
    Exit Function
Failed:
    Set SendOnce = Nothing
End Function

Private Sub Discover()
    Dim path As String
    path = EndpointFilePath()
    If Not CreateObject("Scripting.FileSystemObject").FileExists(path) Then Err.Raise NXT_ERR_NOT_RUNNING, "ExsitecDataLink", Text("missingDiscovery")
    Dim ep As Object
    Set ep = ParseJson(ReadUtf8File(path))
    mBaseUrl = "http://127.0.0.1:" & CStr(CLng(ep("port")))
    mKey = CStr(ep("key"))
    If ep.Exists("instanceId") Then mInstanceId = CStr(ep("instanceId"))
End Sub

Private Function EndpointFilePath() As String
    If Len(mEndpointFile) > 0 Then EndpointFilePath = mEndpointFile Else EndpointFilePath = Environ$("LOCALAPPDATA") & DISCOVERY_SUFFIX
End Function

Private Sub CaptureInstance(ByVal http As Object)
    Dim value As String
    value = SafeHeader(http, HDR_INSTANCE)
    If Len(value) > 0 Then mInstanceId = value
End Sub

Private Function ParseResponse(ByVal http As Object) As Object
    If Len(Trim$(http.ResponseText)) = 0 Then Set ParseResponse = NewDict() Else Set ParseResponse = ParseJson(http.ResponseText)
End Function

Private Sub RaiseResponseError(ByVal status As Long, ByVal response As Object)
    Dim code As String, message As String
    code = CodeForStatus(status): message = "HTTP " & CStr(status)
    If Not response Is Nothing Then
        If response.Exists("code") Then code = CStr(response("code"))
        If response.Exists("message") Then message = CStr(response("message"))
        If response.Exists("errors") Then
            code = "nxt"
            ReadFirstGraphQlError response, code, message
        End If
    End If
    RaiseMappedError code, message
End Sub

Private Sub RaiseGraphQlErrors(ByVal response As Object)
    If response Is Nothing Then Exit Sub
    If Not response.Exists("errors") Then Exit Sub
    If Not IsObject(response("errors")) Then Exit Sub
    If response("errors").Count = 0 Then Exit Sub
    Dim code As String, message As String
    code = "nxt": message = Text("nxtError")
    ReadFirstGraphQlError response, code, message
    RaiseMappedError code, message
End Sub

Private Sub ReadFirstGraphQlError(ByVal response As Object, ByRef code As String, ByRef message As String)
    On Error Resume Next
    Dim firstError As Object
    Set firstError = response("errors")(1)
    If firstError.Exists("message") Then message = CStr(firstError("message"))
    If firstError.Exists("extensions") Then If firstError("extensions").Exists("code") Then code = CStr(firstError("extensions")("code"))
    On Error GoTo 0
End Sub

Private Sub RaiseMappedError(ByVal code As String, ByVal message As String)
    Select Case LCase$(code)
        Case "unauthorized": BeginSignInAndRaise
        Case "forbidden": Err.Raise NXT_ERR_FORBIDDEN, "ExsitecDataLink", Text("forbidden") & " " & message
        Case "invalid_request": Err.Raise NXT_ERR_INVALID, "ExsitecDataLink", Text("invalid") & " " & message
        Case "unavailable": Err.Raise NXT_ERR_UNAVAILABLE, "ExsitecDataLink", Text("unavailable") & " " & message
        Case "nxt", "": Err.Raise NXT_ERR_NXT, "ExsitecDataLink", message
        Case Else: Err.Raise NXT_ERR_OTHER, "ExsitecDataLink", message
    End Select
End Sub

Private Function CodeForStatus(ByVal status As Long) As String
    Select Case status
        Case 400: CodeForStatus = "invalid_request"
        Case 401: CodeForStatus = "unauthorized"
        Case 403: CodeForStatus = "forbidden"
        Case 503: CodeForStatus = "unavailable"
        Case Else: CodeForStatus = "internal_error"
    End Select
End Function

Private Function IsAuthenticated(ByVal status As Object) As Boolean
    On Error Resume Next
    IsAuthenticated = (status("provider")("authenticated") = True)
    On Error GoTo 0
End Function

Private Function IsQueryDocument(ByVal gql As String) As Boolean
    IsQueryDocument = Not StartsWithKeyword(gql, "mutation")
End Function

Private Function StartsWithKeyword(ByVal gql As String, ByVal keyword As String) As Boolean
    Dim s As String
    s = TrimGraphQlStart(gql)
    If LCase$(Left$(s, Len(keyword))) <> keyword Then Exit Function
    If Len(s) = Len(keyword) Then StartsWithKeyword = True: Exit Function
    StartsWithKeyword = InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_", Mid$(s, Len(keyword) + 1, 1)) = 0
End Function

Private Function TrimGraphQlStart(ByVal gql As String) As String
    Dim s As String
    s = LTrim$(gql)
    Do While Left$(s, 1) = "#"
        Dim p As Long
        p = InStr(s, vbLf)
        If p = 0 Then TrimGraphQlStart = "": Exit Function
        s = LTrim$(Mid$(s, p + 1))
    Loop
    TrimGraphQlStart = s
End Function

Private Function SetStatusBar(ByVal value As String) As Variant
    On Error Resume Next
    SetStatusBar = Application.StatusBar
    Application.StatusBar = value
    On Error GoTo 0
End Function

Private Sub RestoreStatusBar(ByVal previousValue As Variant)
    On Error Resume Next
    Application.StatusBar = previousValue
    On Error GoTo 0
End Sub

Private Sub PauseSeconds(ByVal seconds As Double)
    Dim started As Single
    started = Timer
    Do While Not Elapsed(started, seconds)
        DoEvents
    Loop
End Sub

Private Function Elapsed(ByVal started As Single, ByVal seconds As Double) As Boolean
    Dim diff As Double
    If Timer >= started Then diff = Timer - started Else diff = (86400 - started) + Timer
    Elapsed = diff >= seconds
End Function

Private Function SafeHeader(ByVal http As Object, ByVal name As String) As String
    On Error Resume Next
    SafeHeader = http.GetResponseHeader(name)
    On Error GoTo 0
End Function

Private Function ReadUtf8File(ByVal path As String) As String
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2: stream.Charset = "utf-8": stream.Open
    stream.LoadFromFile path
    ReadUtf8File = stream.ReadText(-1)
    stream.Close
End Function

Private Function CurrentLanguage() As String
    If Len(mLanguageOverride) > 0 Then CurrentLanguage = LCase$(mLanguageOverride): Exit Function
    On Error GoTo DefaultLanguage
    Dim path As String
    path = Environ$("LOCALAPPDATA") & SETTINGS_SUFFIX
    If Not CreateObject("Scripting.FileSystemObject").FileExists(path) Then GoTo DefaultLanguage
    Dim settings As Object
    Set settings = ParseJson(ReadUtf8File(path))
    If settings.Exists("language") Then CurrentLanguage = LCase$(CStr(settings("language"))): Exit Function
DefaultLanguage:
    CurrentLanguage = "en"
End Function

Private Function Text(ByVal key As String) As String
    Dim lang As String
    lang = CurrentLanguage()
    If Left$(lang, 2) = "da" Or lang = "dk" Then Text = TextDa(key): Exit Function
    If Left$(lang, 2) = "sv" Or lang = "se" Then Text = TextSv(key): Exit Function
    If Left$(lang, 2) = "nb" Or Left$(lang, 2) = "no" Then Text = TextNb(key): Exit Function
    Text = TextEn(key)
End Function

Private Function TextEn(ByVal key As String) As String
    Select Case key
        Case "starting": TextEn = "Starting Exsitec Data Link" & ChrW(8230)
        Case "notRunning": TextEn = "Could not start or reach Exsitec Data Link. Install or start it from:"
        Case "missingDiscovery": TextEn = "The Exsitec Data Link discovery file was not found."
        Case "signInPrompt": TextEn = "You are not signed in to Exsitec Data Link. You will be sent to the Visma sign-in page in your browser."
        Case "signingIn": TextEn = "Waiting for Visma sign-in" & ChrW(8230)
        Case "signInAgain": TextEn = "Run the action again once you are signed in to Exsitec Data Link."
        Case "signInCanceled": TextEn = "Sign-in was canceled. Run the action again after signing in to Exsitec Data Link."
        Case "invalid": TextEn = "The Business NXT request is invalid."
        Case "forbidden": TextEn = "You do not have Data Link rights for this request."
        Case "unavailable": TextEn = "Exsitec Data Link or the rights service is unavailable."
        Case "badVars": TextEn = "NxtVars needs name/value pairs."
        Case "emptyQuery": TextEn = "NxtQuery needs a GraphQL document."
        Case "nxtError": TextEn = "Business NXT returned an error."
    End Select
End Function

Private Function TextDa(ByVal key As String) As String
    Select Case key
        Case "starting": TextDa = "Starter Exsitec Data Link" & ChrW(8230)
        Case "notRunning": TextDa = "Exsitec Data Link kunne ikke startes eller kontaktes. Installer eller start den herfra:"
        Case "missingDiscovery": TextDa = "Discovery-filen til Exsitec Data Link blev ikke fundet."
        Case "signInPrompt": TextDa = "Du er ikke logget ind i Exsitec Data Link. Du bliver sendt til Vismas login-side i browseren."
        Case "signingIn": TextDa = "Venter p" & ChrW(229) & " Visma-login" & ChrW(8230)
        Case "signInAgain": TextDa = "K" & ChrW(248) & "r handlingen igen, n" & ChrW(229) & "r du er logget ind i Exsitec Data Link."
        Case "signInCanceled": TextDa = "Login blev annulleret. K" & ChrW(248) & "r handlingen igen efter login i Exsitec Data Link."
        Case "invalid": TextDa = "Business NXT-foresp" & ChrW(248) & "rgslen er ugyldig."
        Case "forbidden": TextDa = "Du har ikke Data Link-rettigheder til denne foresp" & ChrW(248) & "rgsel."
        Case "unavailable": TextDa = "Exsitec Data Link eller rettighedstjenesten er utilg" & ChrW(230) & "ngelig."
        Case Else: TextDa = TextEn(key)
    End Select
End Function

Private Function TextSv(ByVal key As String) As String
    Select Case key
        Case "starting": TextSv = "Startar Exsitec Data Link" & ChrW(8230)
        Case "notRunning": TextSv = "Exsitec Data Link kunde inte startas eller n" & ChrW(229) & "s. Installera eller starta den h" & ChrW(228) & "rifr" & ChrW(229) & "n:"
        Case "missingDiscovery": TextSv = "Discovery-filen f" & ChrW(246) & "r Exsitec Data Link hittades inte."
        Case "signInPrompt": TextSv = "Du " & ChrW(228) & "r inte inloggad i Exsitec Data Link. Du skickas till Vismas inloggningssida i webbl" & ChrW(228) & "saren."
        Case "signingIn": TextSv = "V" & ChrW(228) & "ntar p" & ChrW(229) & " Visma-inloggning" & ChrW(8230)
        Case "signInAgain": TextSv = "K" & ChrW(246) & "r " & ChrW(229) & "tg" & ChrW(228) & "rden igen n" & ChrW(228) & "r du " & ChrW(228) & "r inloggad i Exsitec Data Link."
        Case "signInCanceled": TextSv = "Inloggningen avbr" & ChrW(246) & "ts. K" & ChrW(246) & "r " & ChrW(229) & "tg" & ChrW(228) & "rden igen efter inloggning i Exsitec Data Link."
        Case "invalid": TextSv = "Business NXT-beg" & ChrW(228) & "ran " & ChrW(228) & "r ogiltig."
        Case "forbidden": TextSv = "Du saknar Data Link-r" & ChrW(228) & "ttigheter f" & ChrW(246) & "r den h" & ChrW(228) & "r beg" & ChrW(228) & "ran."
        Case "unavailable": TextSv = "Exsitec Data Link eller r" & ChrW(228) & "ttighetstj" & ChrW(228) & "nsten " & ChrW(228) & "r inte tillg" & ChrW(228) & "nglig."
        Case Else: TextSv = TextEn(key)
    End Select
End Function

Private Function TextNb(ByVal key As String) As String
    Select Case key
        Case "starting": TextNb = "Starter Exsitec Data Link" & ChrW(8230)
        Case "notRunning": TextNb = "Exsitec Data Link kunne ikke startes eller n" & ChrW(229) & "s. Installer eller start den herfra:"
        Case "missingDiscovery": TextNb = "Discovery-filen for Exsitec Data Link ble ikke funnet."
        Case "signInPrompt": TextNb = "Du er ikke logget inn i Exsitec Data Link. Du blir sendt til Vismas innloggingsside i nettleseren."
        Case "signingIn": TextNb = "Venter p" & ChrW(229) & " Visma-innlogging" & ChrW(8230)
        Case "signInAgain": TextNb = "Kj" & ChrW(248) & "r handlingen igjen n" & ChrW(229) & "r du er logget inn i Exsitec Data Link."
        Case "signInCanceled": TextNb = "Innloggingen ble avbrutt. Kj" & ChrW(248) & "r handlingen igjen etter innlogging i Exsitec Data Link."
        Case "invalid": TextNb = "Business NXT-foresp" & ChrW(248) & "rselen er ugyldig."
        Case "forbidden": TextNb = "Du har ikke Data Link-rettigheter til denne foresp" & ChrW(248) & "rselen."
        Case "unavailable": TextNb = "Exsitec Data Link eller rettighetstjenesten er utilgjengelig."
        Case Else: TextNb = TextEn(key)
    End Select
End Function

Private Function IsoToDate(ByVal iso As String) As Date
    Dim s As String
    s = Left$(Trim$(iso), 10)
    If Not (s Like "####-##-##") Then Err.Raise 5, "ExsitecDataLink.IsoToDate", "Not an ISO date (yyyy-mm-dd): '" & iso & "'."
    Dim d As Date
    d = DateSerial(CInt(Left$(s, 4)), CInt(Mid$(s, 6, 2)), CInt(Right$(s, 2)))
    If Format$(d, "yyyy-mm-dd") <> s Then Err.Raise 5, "ExsitecDataLink.IsoToDate", "Not a valid date: '" & iso & "'."
    IsoToDate = d
End Function
'--- Worksheet output --------------------------------------------------------------

' Writes JSON rows (a Collection of Dictionaries, e.g. the "rows" of a ledger query) to a
' sheet in one block from target's top-left cell, and returns the range written
' (Nothing when there is nothing to write).
'   columns       : field names in the order to write, e.g. Array("date", "amount");
'                   a dot reaches into a nested object ("dimensions.project").
'                   Omitted = every field seen, nested objects expanded one level.
'   includeHeader : write the field names as the first row (default True).
' ISO dates become real Excel dates, JSON null an empty cell, a nested array JSON
' text, and text Excel would take for a formula (=, +, -, @) stays text.
Public Function WriteRows(ByVal rows As Collection, ByVal target As Range, _
        Optional ByVal columns As Variant, Optional ByVal includeHeader As Boolean = True) As Range
    Dim names As Collection
    If IsMissing(columns) Then
        Set names = ColumnsOf(rows)
    Else
        Set names = New Collection
        If IsArray(columns) Then
            Dim c As Variant
            For Each c In columns
                names.Add CStr(c)
            Next c
        Else
            names.Add CStr(columns)
        End If
    End If

    Dim headerRows As Long
    If includeHeader Then headerRows = 1
    Dim total As Long
    total = rows.Count + headerRows
    If names.Count = 0 Or total = 0 Then Exit Function

    Dim data() As Variant
    ReDim data(1 To total, 1 To names.Count)
    Dim col As Long
    If includeHeader Then
        For col = 1 To names.Count
            data(1, col) = names(col)
        Next col
    End If

    Dim r As Long
    r = headerRows
    Dim row As Variant
    For Each row In rows
        r = r + 1
        For col = 1 To names.Count
            data(r, col) = CellValue(row, names(col))
        Next col
    Next row

    Dim block As Range
    Set block = target.Cells(1, 1).Resize(total, names.Count)
    block.Value = data
    Set WriteRows = block
End Function

'--- Private -----------------------------------------------------------------------

' Every field name seen in the rows, in first-seen order; a nested object expands
' one level ("dimensions.project") so each cell holds a single value.
Private Function ColumnsOf(ByVal rows As Collection) As Collection
    Dim seen As Object
    Set seen = CreateObject("Scripting.Dictionary")
    Dim row As Variant, key As Variant, subKey As Variant
    For Each row In rows
        If TypeName(row) = "Dictionary" Then
            For Each key In row.Keys
                If TypeName(row(key)) = "Dictionary" Then
                    For Each subKey In row(key).Keys
                        If Not seen.Exists(key & "." & subKey) Then seen.Add key & "." & subKey, True
                    Next subKey
                ElseIf Not seen.Exists(CStr(key)) Then
                    seen.Add CStr(key), True
                End If
            Next key
        End If
    Next row

    Dim names As Collection
    Set names = New Collection
    For Each key In seen.Keys
        names.Add CStr(key)
    Next key
    Set ColumnsOf = names
End Function

' The cell value for one row and a (dotted) field path; Empty when it is absent.
Private Function CellValue(ByVal row As Variant, ByVal path As String) As Variant
    If Len(path) = 0 Then Exit Function
    If TypeName(row) <> "Dictionary" Then Exit Function

    Dim node As Object
    Set node = row
    Dim parts() As String
    parts = Split(path, ".")
    Dim i As Long
    For i = 0 To UBound(parts) - 1
        If Not node.Exists(parts(i)) Then Exit Function
        If TypeName(node(parts(i))) <> "Dictionary" Then Exit Function
        Set node = node(parts(i))
    Next i

    Dim leaf As String
    leaf = parts(UBound(parts))
    If Not node.Exists(leaf) Then Exit Function

    If IsObject(node(leaf)) Then
        CellValue = Stringify(node(leaf))
    ElseIf IsNull(node(leaf)) Then
        CellValue = Empty
    ElseIf VarType(node(leaf)) = vbString Then
        CellValue = CellText(CStr(node(leaf)))
    Else
        CellValue = node(leaf)
    End If
End Function

' Excel re-interprets some text on assignment: an ISO date becomes a real date here on
' purpose, while text that looks like a formula is kept as text.
Private Function CellText(ByVal text As String) As Variant
    If text Like "####-##-##" Then
        On Error GoTo KeepText
        CellText = IsoToDate(text)
        Exit Function
    End If
    Select Case Left$(text, 1)
        Case "=", "+", "-", "@"
            CellText = "'" & text
        Case Else
            CellText = text
    End Select
    Exit Function
KeepText:
    CellText = text
End Function

'====================================================================================
' ExsitecDataLink  -  minimal, dependency-free JSON for the Exsitec Data Link VBA SDK
'
' Parses connector responses into Scripting.Dictionary (objects) and Collection
' (arrays), and serializes the same shapes back to a request body.
'
' Locale safety (this workbook runs on Danish regional settings):
'   - numbers are WRITTEN with Str$ (always "." decimal, never a comma)
'   - numbers are READ with Val   (always "." decimal, ignores the locale comma)
' Never use CStr/CDbl/Format for JSON numbers - they follow the regional decimal
' separator and would corrupt amounts.
'
' Late binding only (Scripting.Dictionary via CreateObject): no project reference
' to add, so the module drops into any workbook unchanged.
'====================================================================================


'--- Builders callers use to assemble request bodies -------------------------------

Private Function NewDict() As Object
    Set NewDict = CreateObject("Scripting.Dictionary")
End Function

Private Function NewList() As Collection
    Set NewList = New Collection
End Function

'--- Parse -------------------------------------------------------------------------

' Returns Dictionary | Collection | String | Double | Boolean | Null.
Private Function ParseJson(ByVal json As String) As Variant
    mText = json
    mLen = Len(json)
    mPos = 1
    SkipWhitespace
    Dim result As Variant
    AssignVariant result, ParseValue()
    SkipWhitespace
    If mPos <= mLen Then
        Err.Raise vbObjectError + 1000, "ExsitecDataLink.Parse", _
            "Unexpected trailing content at position " & mPos & "."
    End If
    If IsObject(result) Then Set ParseJson = result Else ParseJson = result
End Function

Private Function ParseValue() As Variant
    Dim ch As String
    SkipWhitespace
    If mPos > mLen Then
        Err.Raise vbObjectError + 1001, "ExsitecDataLink", "Unexpected end of JSON."
    End If

    ch = Mid$(mText, mPos, 1)
    Select Case ch
        Case "{"
            Set ParseValue = ParseObject()
        Case "["
            Set ParseValue = ParseArray()
        Case """"
            ParseValue = ParseString()
        Case "t", "f"
            ParseValue = ParseBoolean()
        Case "n"
            ParseLiteral "null"
            ParseValue = Null
        Case Else
            ParseValue = ParseNumber()
    End Select
End Function

Private Function ParseObject() As Object
    Dim result As Object
    Set result = CreateObject("Scripting.Dictionary")
    mPos = mPos + 1 ' consume {
    SkipWhitespace
    If Mid$(mText, mPos, 1) = "}" Then
        mPos = mPos + 1
        Set ParseObject = result
        Exit Function
    End If

    Do
        Dim key As String
        SkipWhitespace
        key = ParseString()
        SkipWhitespace
        Expect ":"
        Dim value As Variant
        AssignVariant value, ParseValue()
        If IsObject(value) Then
            Set result(key) = value
        Else
            result(key) = value
        End If
        SkipWhitespace
        Dim sep As String
        sep = Mid$(mText, mPos, 1)
        mPos = mPos + 1
        If sep = "}" Then Exit Do
        If sep <> "," Then
            Err.Raise vbObjectError + 1002, "ExsitecDataLink", "Expected ',' or '}' in object."
        End If
    Loop
    Set ParseObject = result
End Function

Private Function ParseArray() As Collection
    Dim result As Collection
    Set result = New Collection
    mPos = mPos + 1 ' consume [
    SkipWhitespace
    If Mid$(mText, mPos, 1) = "]" Then
        mPos = mPos + 1
        Set ParseArray = result
        Exit Function
    End If

    Do
        Dim value As Variant
        AssignVariant value, ParseValue()
        result.Add value
        SkipWhitespace
        Dim sep As String
        sep = Mid$(mText, mPos, 1)
        mPos = mPos + 1
        If sep = "]" Then Exit Do
        If sep <> "," Then
            Err.Raise vbObjectError + 1003, "ExsitecDataLink", "Expected ',' or ']' in array."
        End If
    Loop
    Set ParseArray = result
End Function

Private Function ParseString() As String
    Expect """"
    Dim sb As String
    Do While mPos <= mLen
        Dim ch As String
        ch = Mid$(mText, mPos, 1)
        mPos = mPos + 1
        If ch = """" Then
            ParseString = sb
            Exit Function
        ElseIf ch = "\" Then
            Dim esc As String
            esc = Mid$(mText, mPos, 1)
            mPos = mPos + 1
            Select Case esc
                Case """": sb = sb & """"
                Case "\": sb = sb & "\"
                Case "/": sb = sb & "/"
                Case "b": sb = sb & Chr$(8)
                Case "f": sb = sb & Chr$(12)
                Case "n": sb = sb & vbLf
                Case "r": sb = sb & vbCr
                Case "t": sb = sb & vbTab
                Case "u"
                    sb = sb & ChrW$(CLng("&H" & Mid$(mText, mPos, 4)))
                    mPos = mPos + 4
                Case Else
                    Err.Raise vbObjectError + 1004, "ExsitecDataLink", "Bad string escape '\" & esc & "'."
            End Select
        Else
            sb = sb & ch
        End If
    Loop
    Err.Raise vbObjectError + 1005, "ExsitecDataLink", "Unterminated string."
End Function

Private Function ParseNumber() As Double
    Dim startPos As Long
    startPos = mPos
    Do While mPos <= mLen
        Dim ch As String
        ch = Mid$(mText, mPos, 1)
        If InStr("0123456789+-.eE", ch) = 0 Then Exit Do
        mPos = mPos + 1
    Loop
    If mPos = startPos Then
        Err.Raise vbObjectError + 1006, "ExsitecDataLink", "Invalid number at position " & startPos & "."
    End If
    ' Val is locale-independent: it always reads "." as the decimal point.
    ParseNumber = Val(Mid$(mText, startPos, mPos - startPos))
End Function

Private Function ParseBoolean() As Boolean
    If Mid$(mText, mPos, 4) = "true" Then
        mPos = mPos + 4
        ParseBoolean = True
    ElseIf Mid$(mText, mPos, 5) = "false" Then
        mPos = mPos + 5
        ParseBoolean = False
    Else
        Err.Raise vbObjectError + 1007, "ExsitecDataLink", "Invalid literal; expected true/false."
    End If
End Function

Private Sub ParseLiteral(ByVal literal As String)
    If Mid$(mText, mPos, Len(literal)) <> literal Then
        Err.Raise vbObjectError + 1008, "ExsitecDataLink", "Expected literal '" & literal & "'."
    End If
    mPos = mPos + Len(literal)
End Sub

Private Sub Expect(ByVal ch As String)
    If Mid$(mText, mPos, 1) <> ch Then
        Err.Raise vbObjectError + 1009, "ExsitecDataLink", _
            "Expected '" & ch & "' at position " & mPos & "."
    End If
    mPos = mPos + 1
End Sub

Private Sub SkipWhitespace()
    Do While mPos <= mLen
        Select Case Mid$(mText, mPos, 1)
            Case " ", vbTab, vbCr, vbLf
                mPos = mPos + 1
            Case Else
                Exit Do
        End Select
    Loop
End Sub

'--- Serialize ---------------------------------------------------------------------

Private Function Stringify(ByVal value As Variant) As String
    Select Case VarType(value)
        Case vbObject
            If value Is Nothing Then
                Stringify = "null"
            ElseIf TypeName(value) = "Dictionary" Then
                Stringify = StringifyDictionary(value)
            ElseIf TypeName(value) = "Collection" Then
                Stringify = StringifyCollection(value)
            Else
                Err.Raise vbObjectError + 1010, "ExsitecDataLink.Stringify", _
                    "Cannot serialize object of type '" & TypeName(value) & "'."
            End If
        Case vbNull, vbEmpty
            Stringify = "null"
        Case vbString
            Stringify = QuoteString(CStr(value))
        Case vbBoolean
            Stringify = IIf(value, "true", "false")
        Case vbDate
            ' Contract dates are date-only strings; the literal dashes are locale-safe.
            Stringify = QuoteString(Format$(value, "yyyy-mm-dd"))
        Case Else
            Stringify = NumberToJson(value)
    End Select
End Function

Private Function StringifyDictionary(ByVal dict As Object) As String
    Dim parts As String
    Dim key As Variant
    Dim first As Boolean
    first = True
    For Each key In dict.Keys
        If Not first Then parts = parts & ","
        parts = parts & QuoteString(CStr(key)) & ":" & Stringify(dict(key))
        first = False
    Next key
    StringifyDictionary = "{" & parts & "}"
End Function

Private Function StringifyCollection(ByVal list As Collection) As String
    Dim parts As String
    Dim item As Variant
    Dim first As Boolean
    first = True
    For Each item In list
        If Not first Then parts = parts & ","
        parts = parts & Stringify(item)
        first = False
    Next item
    StringifyCollection = "[" & parts & "]"
End Function

Private Function NumberToJson(ByVal value As Variant) As String
    ' Str$ always emits "." as the decimal separator and a leading space for
    ' non-negative values; JSON forbids a bare leading ".", so pad a zero.
    Dim s As String
    s = Trim$(Str$(value))
    If Left$(s, 1) = "." Then
        s = "0" & s
    ElseIf Left$(s, 2) = "-." Then
        s = "-0" & Mid$(s, 2)
    End If
    NumberToJson = s
End Function

Private Function QuoteString(ByVal value As String) As String
    Dim sb As String
    Dim i As Long
    For i = 1 To Len(value)
        Dim ch As String
        ch = Mid$(value, i, 1)
        Select Case ch
            Case """": sb = sb & "\"""
            Case "\": sb = sb & "\\"
            Case vbLf: sb = sb & "\n"
            Case vbCr: sb = sb & "\r"
            Case vbTab: sb = sb & "\t"
            Case Chr$(8): sb = sb & "\b"
            Case Chr$(12): sb = sb & "\f"
            Case Else
                If AscW(ch) < 32 Then
                    sb = sb & "\u" & Right$("0000" & Hex$(AscW(ch)), 4)
                Else
                    sb = sb & ch
                End If
        End Select
    Next i
    QuoteString = """" & sb & """"
End Function

' Assigns either an object or a scalar to a Variant (VBA needs Set vs Let split).
Private Sub AssignVariant(ByRef target As Variant, ByRef source As Variant)
    If IsObject(source) Then
        Set target = source
    Else
        target = source
    End If
End Sub