diff --git a/JSON.bas b/JSON.bas new file mode 100644 index 0000000..ae38969 --- /dev/null +++ b/JSON.bas @@ -0,0 +1,135 @@ +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 + diff --git a/login.frm b/login.frm index 4a501e1..3b2655b 100644 --- a/login.frm +++ b/login.frm @@ -15,6 +15,7 @@ Attribute VB_PredeclaredId = True Attribute VB_Exposed = False + Public proceed As Boolean diff --git a/login.frx b/login.frx index aa2da2f..b63787d 100644 Binary files a/login.frx and b/login.frx differ