DATA_MIGRATION/SQL/SQLtoJSON/SQLtoJSON_VBA.vb at master · ParfaitG/DATA_MIGRATION · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

''''''''''''''''''
'' MS ACCESS VBA
''''''''''''''''''
Public Sub SQLtoJSON_ACC()
On Error GoTo ErrHandle
    Dim db As Database, tbldef As TableDef, rst As Recordset
    Dim strpath, jsonfile, jsonstring As String

    Dim xmldata As Collection, innerdata As Object
    Dim i, FileNum As Integer
    Dim key As String, val As String

    strpath = Application.CurrentProject.Path

    Set db = CurrentDb

    ' REMOVE LINKED TABLE
    For Each tbldef In db.TableDefs
        If tbldef.Name = "MyCLData" Then
            db.Execute "DROP TABLE CLData_Linked"
        End If
    Next tbldef

    ' CREATE LINKED TABLE
    DoCmd.TransferDatabase acLink, "ODBC Database", _
          "ODBC;DRIVER=SQLite3 ODBC Driver;Database=" & strPath & "\CLData.db;", _
          acTable, "CLData", "CLData_linked"

    ' QUERY DATABASE
    Set rst = db.OpenRecordset("CLData_Linked", dbOpenDynaset)

    ' CONVERT DATA TO DICTIONARY
    Set xmldata = New Collection
    Do While Not rst.EOF
        Set innerdata = CreateObject("Scripting.Dictionary")

        For i = 1 to rst.Fields.Count
            key = rst.Fields(i - 0).Name: val = rst.Fields(i - 0).Value
            innerdata.Add key, val
        Next i
        xmldata.Add innerdata
        Set innerdata = Nothing
        rst.MoveNext
    Loop

    rst.Close

    ' WRITE JSON
    jsonstring = ConvertToJson(xmldata)
    jsonstring = PrettyPrint(jsonstring)

    jsonfile = strpath & "\CLData_ACC.json"

    FileNum = FreeFile()
    Open jsonfile For Output As #FileNum
        Print #FileNum, finalstring
    Close #FileNum

    MsgBox "Successfully migrated SQL data to JSON!", vbInformation

ExitHandle:
    Set innerdata = Nothing: Set xmldata = Nothing
    Set tbldef = Nothing: Set rst = Nothing: Set db = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Resume ExitHandle

End Sub


Public Function PrettyPrint(rawJson As String) As String
    Dim prettyJSON As String

    prettyJSON = Replace(rawJson, Chr$(34) & ",", Chr(34) & "," & vbNewLine & vbTab)
    prettyJSON = Replace(prettyJSON, "[", "[" & vbNewLine)
    prettyJSON = Replace(prettyJSON, "{", Space(3) & "{" & vbNewLine & vbTab)
    prettyJSON = Replace(prettyJSON, "},", vbNewLine & Space(3) & "}," & vbNewLine)
    prettyJSON = Replace(prettyJSON, "}]", vbNewLine & Space(3) & "}" & vbNewLine & "]")
    prettyJSON = Replace(prettyJSON, Chr$(34) & ":", Chr(34) & ": ")

    PrettyPrint = prettyJSON

End Function


''''''''''''''''''
'' MS EXCEL VBA
''''''''''''''''''
Public Sub SQLtoJSON_XL()
On Error GoTo ErrHandle
    Dim conn, rst As Object
    Dim strpath, jsonfile, constr As String

    Dim sqldata As Collection, innerdata As Object
    Dim i As Long, jsonstring As String
    Dim key, val As String

    Dim FileNum As Integer

    strpath = ActiveWorkbook.Path

    ' OPEN DB CONNECTION
    Set conn = CreateObject("ADODB.Connection")
    constr = "DRIVER=SQLite3 ODBC Driver;Database=" & strPath & "\CLData.db;"
    conn.Open constr

    ' QUERY DATABASE
    Set rst = CreateObject("ADODB.Recordset")
    rst.Open "SELECT * FROM cldata", conn

    ' CONVERT TO DICTIONARY
    Set sqldata = New Collection
    Do While Not rst.EOF
        Set innerdata = CreateObject("Scripting.Dictionary")

        For i = 1 to rst.Fields.Count
            key = rst.Fields(i - 1).Name: val = rst.Fields(i - 1).Value
            innerdata.Add key, val
        Next i

        sqldata.Add innerdata
        Set innerdata = Nothing

        rst.MoveNext
    Loop

    ' SAVE JSON
    jsonstring = ConvertToJson(sqldata)
    jsonstring = PrettyPrint(jsonstring)

    jsonfile = strpath & "\CLData_XL.json"

    FileNum = FreeFile()
    Open jsonfile For Output As #FileNum
        Print #FileNum, finalstring
    Close #FileNum

    MsgBox "Successfully migrated SQL data to JSON!", vbInformation

    rst.Close: conn.Close

ExitHandle:
    Set sqldata = Nothing: Set xmldata = Nothing
    Set rst = Nothing: Set conn = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Resume ExitHandle

End Sub


Public Function PrettyPrint(rawJson As String) As String
    Dim prettyJSON As String

    prettyJSON = Replace(rawJson, Chr$(34) & ",", Chr(34) & "," & vbNewLine & vbTab)
    prettyJSON = Replace(prettyJSON, "[", "[" & vbNewLine)
    prettyJSON = Replace(prettyJSON, "{", Space(3) & "{" & vbNewLine & vbTab)
    prettyJSON = Replace(prettyJSON, "},", vbNewLine & Space(3) & "}," & vbNewLine)
    prettyJSON = Replace(prettyJSON, "}]", vbNewLine & Space(3) & "}" & vbNewLine & "]")
    prettyJSON = Replace(prettyJSON, Chr$(34) & ":", Chr(34) & ": ")

    PrettyPrint = prettyJSON

End Function