136 lines
4.0 KiB
QBasic
136 lines
4.0 KiB
QBasic
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
|
||
|