Attribute VB_Name = "JSON"
Option Explicit

'====== Public API ======'
' UDF: returns JSON as string (may be large for a cell)
Public Function RangeToJSON(tbl As Range, Optional TreatEmptyAsNull As Boolean = True) As String
    On Error GoTo Fail
    RangeToJSON = BuildJSON(tbl, TreatEmptyAsNull)
    Exit Function
Fail:
    RangeToJSON = "[]"
End Function

' Macro: saves the selected range to a JSON file
Public Sub ExportRangeToJSON()
    Dim rng As Range, js As String, f As Variant, ff As Integer
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select a rectangular range first.", vbExclamation
        Exit Sub
    End If
    Set rng = Selection
    js = BuildJSON(rng, True)
    f = Application.GetSaveAsFilename(InitialFileName:="data.json", FileFilter:="JSON Files (*.json), *.json")
    If f = False Then Exit Sub
    ff = FreeFile
    Open CStr(f) For Output As #ff
    Print #ff, js
    Close #ff
    MsgBox "Saved JSON to: " & f, vbInformation
End Sub

'====== Core ======'
Private Function BuildJSON(tbl As Range, TreatEmptyAsNull As Boolean) As String
    Dim arr As Variant, r As Long, c As Long
    Dim rCount As Long, cCount As Long
    Dim headers() As String
    Dim rows() As String
    Dim pairs() As String
    Dim rowJSON As String

    If tbl Is Nothing Then BuildJSON = "[]": Exit Function
    If tbl.rows.Count < 2 Or tbl.Columns.Count < 1 Then BuildJSON = "[]": Exit Function

    arr = tbl.Value ' 1-based 2D variant array
    rCount = UBound(arr, 1)
    cCount = UBound(arr, 2)

    ' Guard: header-only range
    If rCount < 2 Then BuildJSON = "[]": Exit Function

    ' Build headers (escape blanks to col1/col2/...)
    ReDim headers(1 To cCount)
    For c = 1 To cCount
        headers(c) = JsonEscape(CStr(arr(1, c)))
        If Len(headers(c)) = 0 Then headers(c) = "col" & CStr(c)
    Next c

    ' Build each row object: {"h1":val1,"h2":val2,...}
    ReDim rows(1 To rCount - 1)
    For r = 2 To rCount
        ReDim pairs(1 To cCount)
        For c = 1 To cCount
            pairs(c) = """" & headers(c) & """:" & CellToJSON(arr(r, c), TreatEmptyAsNull)
        Next c
        rowJSON = "{" & Join(pairs, ",") & "}"
        rows(r - 1) = rowJSON
    Next r

    ' Final JSON array
    BuildJSON = "[" & Join(rows, ",") & "]"
End Function


'====== Helpers ======'
Private Function CellToJSON(v As Variant, TreatEmptyAsNull As Boolean) As String
    On Error GoTo Fallback
    ' Errors ? null
    If IsError(v) Then CellToJSON = "null": Exit Function
    ' Empty/blank
    If (VarType(v) = vbEmpty) Or (VarType(v) = vbNull) Or (CStr(v) = "") Then
        If TreatEmptyAsNull Then
            CellToJSON = "null"
        Else
            CellToJSON = """" & """"
        End If
        Exit Function
    End If
    ' Boolean
    If VarType(v) = vbBoolean Then
        CellToJSON = IIf(CBool(v), "true", "false")
        Exit Function
    End If
    ' Date
    If IsDate(v) Then
        CellToJSON = """" & Format$(CDate(v), "yyyy-mm-dd\THH:nn:ss") & """"
        Exit Function
    End If
    ' Numeric (locale-safe with dot)
    If IsNumeric(v) Then
        Dim s As String
        s = CStr(CDbl(v))
        s = Replace(s, Application.DecimalSeparator, ".")
        CellToJSON = s
        Exit Function
    End If
    ' String
    CellToJSON = """" & JsonEscape(CStr(v)) & """"
    Exit Function
Fallback:
    CellToJSON = "null"
End Function

Private Function JsonEscape(s As String) As String
    ' Minimal, safe escaping for JSON
    Dim t As String
    t = Replace(s, "\", "\\")
    t = Replace(t, """", "\""")
    t = Replace(t, vbCrLf, "\n")
    t = Replace(t, vbCr, "\n")
    t = Replace(t, vbLf, "\n")
    ' Control chars 0–31 ? strip (simple approach)
    Dim i As Long, ch As String, code As Integer, out As String
    out = ""
    For i = 1 To Len(t)
        ch = Mid$(t, i, 1)
        code = AscW(ch)
        If code < 32 Then
            ' skip control chars (or map to \u00XX if desired)
        Else
            out = out & ch
        End If
    Next i
    JsonEscape = out
End Function