update

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
+

login.frm

@@ -15,6 +15,7 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+
 Public proceed As Boolean