180 | );
181 | }
182 | }
183 |
184 |
185 | ReactDOM.render(
186 | ,
187 | document.getElementById("app")
188 | );
--------------------------------------------------------------------------------
/test.ps1:
--------------------------------------------------------------------------------
1 | . .\variables.ps1
2 | . .\constants.ps1
3 | . .\log.ps1
4 |
5 | LogInfo "Collecting tests"
6 |
7 | $missing = [System.Reflection.Missing]::Value
8 | $excel = New-Object -ComObject Excel.Application
9 | $book = $excel.Workbooks.Open($FILENAME, $missing, $true)
10 | $modules = $book.VBProject.VBComponents;
11 | $suites = @{}
12 | $suiteFlags = @{}
13 |
14 | $SUITE_FLAG_BEFORE_ALL = 1
15 | $SUITE_FLAG_AFTER_ALL = 2
16 | $SUITE_FLAG_BEFORE_EACH = 4
17 | $SUITE_FLAG_AFTER_EACH = 8
18 |
19 | $testCount = 0
20 |
21 | For ($moduleIndex = 0; $moduleIndex -lt $modules.Count; $moduleIndex++)
22 | {
23 | # vba interop seems to be written in VB6 => indices start at 1
24 | $module = $modules.Item($moduleIndex + 1)
25 |
26 | If (!$module.Name.StartsWith("Test"))
27 | {
28 | Continue
29 | }
30 |
31 | $code = $module.CodeModule.Lines(1, $module.CodeModule.CountOfLines)
32 | $lines = $code.Split("`r`n")
33 |
34 | $suiteFlags[$module.Name] = 0
35 |
36 | ForEach ($line in $lines)
37 | {
38 | If ($line.StartsWith("Public Function Test"))
39 | {
40 | If (!$suites.ContainsKey($module.Name))
41 | {
42 | $suites[$module.Name] = [System.Collections.ArrayList]@()
43 | }
44 |
45 | $testName = $line.Split(" ")[2].Trim("()")
46 | $_ = $suites[$module.Name].Add($testName)
47 | $testCount += 1
48 | }
49 |
50 | If ($line.StartsWith("Public Sub BeforeAll()"))
51 | {
52 | $suiteFlags[$module.Name] = $suiteFlags[$module.Name] -bor $SUITE_FLAG_BEFORE_ALL
53 | }
54 |
55 | If ($line.StartsWith("Public Sub AfterAll()"))
56 | {
57 | $suiteFlags[$module.Name] = $suiteFlags[$module.Name] -bor $SUITE_FLAG_AFTER_ALL
58 | }
59 |
60 | If ($line.StartsWith("Public Sub BeforeEach()"))
61 | {
62 | $suiteFlags[$module.Name] = $suiteFlags[$module.Name] -bor $SUITE_FLAG_BEFORE_EACH
63 | }
64 |
65 | If ($line.StartsWith("Public Sub AfterEach()"))
66 | {
67 | $suiteFlags[$module.Name] = $suiteFlags[$module.Name] -bor $SUITE_FLAG_AFTER_EACH
68 | }
69 | }
70 | }
71 |
72 | LogInfo "Found $($suites.Count) suites with $testCount tests"
73 | LogEmptyLine
74 |
75 | $passedSuites = 0
76 | $passedTests = 0
77 |
78 | Function HasSuiteFlag($flags, $flag)
79 | {
80 | Return ($flags -band $flag) -eq $flag
81 | }
82 |
83 | ForEach ($suite in $suites.Keys)
84 | {
85 | $successful = $true
86 | $tests = $suites[$suite]
87 | $flags = $suiteFlags[$suite]
88 |
89 | $title = $suite + " (" + $tests.Count + " tests)"
90 | echo $title
91 |
92 | $hasBeforeAll = HasSuiteFlag $flags $SUITE_FLAG_BEFORE_ALL
93 | $hasAfterAll = HasSuiteFlag $flags $SUITE_FLAG_AFTER_ALL
94 | $hasBeforeEach = HasSuiteFlag $flags $SUITE_FLAG_BEFORE_EACH
95 | $hasAfterEach = HasSuiteFlag $flags $SUITE_FLAG_AFTER_EACH
96 |
97 | If ($hasBeforeAll)
98 | {
99 | $excel.Run($suite + "." + "BeforeAll")
100 | }
101 |
102 | ForEach ($test in $tests)
103 | {
104 | If ($hasBeforeEach)
105 | {
106 | $excel.Run($suite + "." + "BeforeEach")
107 | }
108 |
109 | $result = $excel.Run($suite + "." + $test)
110 |
111 | Write-Host " " -NoNewline
112 |
113 | if ($result.AssertSuccessful)
114 | {
115 | $passedTests += 1
116 | Write-Host " PASS " -BackgroundColor Green -ForegroundColor White -NoNewline
117 | }
118 | else
119 | {
120 | $successful = $false
121 | Write-Host " FAIL " -BackgroundColor Red -ForegroundColor White -NoNewline
122 | }
123 |
124 | Write-Host " $test" -NoNewline
125 |
126 | if ($result.AssertSuccessful)
127 | {
128 | Write-Host ": $($result.AssertMessage)" -ForegroundColor Gray
129 | }
130 | else
131 | {
132 | LogEmptyLine
133 | LogEmptyLine
134 | Write-Host $result.AssertMessage -ForegroundColor Red
135 | LogEmptyLine
136 | }
137 |
138 | If ($hasAfterEach)
139 | {
140 | $excel.Run($suite + "." + "AfterEach")
141 | }
142 | }
143 |
144 | If ($hasAfterAll)
145 | {
146 | $excel.Run($suite + "." + "AfterAll")
147 | }
148 |
149 | if ($successful)
150 | {
151 | $passedSuites += 1
152 | }
153 |
154 | echo ""
155 | }
156 |
157 | $excel.Quit()
158 |
159 | Function LogSummary($title, $passed, $failed)
160 | {
161 | Write-Host $title -NoNewline
162 | Write-Host "$passed passed" -ForegroundColor Green -NoNewline
163 |
164 | if ($failed -gt 0)
165 | {
166 | Write-Host ", " -NoNewline
167 | Write-Host "${failed} failed" -ForegroundColor Red -NoNewline
168 | }
169 |
170 | $total = $passed + $failed
171 | Write-Host ", $total total"
172 | }
173 |
174 | LogSummary "Test suites: " $passedSuites ($suites.Count - $passedSuites)
175 | LogSummary "Tests: " $passedTests ($testCount - $passedTests)
176 | LogInfo "Ran all test suites."
177 | LogEmptyLine
178 |
--------------------------------------------------------------------------------
/src/Classes/WorksheetTable.cls:
--------------------------------------------------------------------------------
1 | VERSION 1.0 CLASS
2 | BEGIN
3 | MultiUse = -1 'True
4 | END
5 | Attribute VB_Name = "WorksheetTable"
6 | Attribute VB_GlobalNameSpace = False
7 | Attribute VB_Creatable = False
8 | Attribute VB_PredeclaredId = False
9 | Attribute VB_Exposed = False
10 | Private Type ColumnHeader
11 | name As String
12 | index As Integer
13 | End Type
14 |
15 |
16 | Private m_sheet
17 | Private m_columns As Collection
18 | Private m_primaryKey As Integer
19 |
20 |
21 | Public Property Get PrimaryKey() As String
22 | For Each column In m_columns
23 | If column.index = m_primaryKey Then
24 | PrimaryKey = column.name
25 | Exit Property
26 | End If
27 | Next column
28 | End Property
29 |
30 |
31 | Public Property Get Columns() As Collection
32 | Set Columns = New Collection
33 |
34 | For Each column In m_columns
35 | Columns.Add column.name
36 | Next column
37 | End Property
38 |
39 |
40 | Public Property Get Entries() As Collection
41 | Set Entries = New Collection
42 |
43 | Dim i As Long
44 | For i = 2 To m_sheet.Rows.count
45 | Dim row
46 | Set row = m_sheet.Rows(i)
47 |
48 | Dim pkText
49 | pkText = Trim(row.Cells(m_primaryKey))
50 |
51 | If pkText = "" Then
52 | Exit For
53 | End If
54 |
55 | Dim entry
56 | Set entry = CreateObject("Scripting.Dictionary")
57 |
58 | For Each column In m_columns
59 | Dim val
60 | val = Trim(row.Cells(column.index).text)
61 |
62 | If val = "" Then
63 | entry(column.name) = Null
64 | Else
65 | entry(column.name) = val
66 | End If
67 | Next column
68 |
69 | Entries.Add entry
70 | Next i
71 | End Property
72 |
73 |
74 | Public Sub Insert(value)
75 | Dim insertionRow As Long
76 |
77 | insertionRow = m_sheet.Cells(1, m_primaryKey).End(xlDown).row + 1
78 |
79 | If insertionRow = 1048577 Then
80 | For insertionRow = 2 To 1048576
81 | Dim text
82 | text = m_sheet.Cells(insertionRow, m_primaryKey).text
83 | If Trim(text) = "" Then
84 | Exit For
85 | End If
86 | Next insertionRow
87 | End If
88 |
89 | SetRowValues insertionRow, value
90 | End Sub
91 |
92 |
93 | Public Function Delete(key As String)
94 | Set Delete = Nothing
95 |
96 | Dim i As Long
97 | For i = 2 To m_sheet.Rows.count
98 | Dim row
99 | Set row = m_sheet.Rows(i)
100 |
101 | Dim pkText
102 | pkText = Trim(row.Cells(m_primaryKey))
103 |
104 | If pkText = key Then
105 | Dim entry
106 | Set entry = CreateObject("Scripting.Dictionary")
107 |
108 | For Each column In m_columns
109 | Dim val
110 | val = Trim(row.Cells(column.index).text)
111 |
112 | If val = "" Then
113 | entry(column.name) = Null
114 | Else
115 | entry(column.name) = val
116 | End If
117 | Next column
118 |
119 | row.Delete
120 | Set Delete = entry
121 |
122 | Exit Function
123 | End If
124 | Next i
125 | End Function
126 |
127 |
128 | Public Function Update(key As String, values) As Boolean
129 | Update = False
130 |
131 | Dim updateRow As Long
132 | For updateRow = 2 To m_sheet.Rows.count
133 | Dim row
134 | Set row = m_sheet.Rows(updateRow)
135 |
136 | Dim pkText
137 | pkText = Trim(row.Cells(m_primaryKey))
138 |
139 | If pkText = key Then
140 | SetRowValues updateRow, values
141 | Update = True
142 |
143 | Exit Function
144 | End If
145 | Next updateRow
146 | End Function
147 |
148 |
149 | Private Sub SetRowValues(row As Long, values)
150 | For Each column In m_columns
151 | If values.Exists(column.name) Then
152 | Dim insertionCell
153 | Set insertionCell = m_sheet.Cells(row, column.index)
154 |
155 | insertionCell.value = values(column.name)
156 | End If
157 | Next column
158 | End Sub
159 |
160 |
161 | Public Sub Initialize(worksheet)
162 | m_primaryKey = -1
163 |
164 | Set m_sheet = worksheet
165 | Set m_columns = New Collection
166 |
167 | Dim firstRow
168 | Set firstRow = m_sheet.Rows(1)
169 |
170 | Dim i As Integer
171 | For i = 1 To firstRow.Cells.count
172 | Dim column
173 | Set column = firstRow.Cells(i)
174 |
175 | Dim text As String
176 | text = Trim(column.text)
177 |
178 | If text = "" Then
179 | Exit For
180 | End If
181 |
182 | Dim header As WorksheetTableColumnHeader
183 | Set header = New WorksheetTableColumnHeader
184 | header.name = text
185 | header.index = i
186 |
187 | m_columns.Add header
188 |
189 | If column.Font.Bold And m_primaryKey = -1 Then
190 | m_primaryKey = i
191 | End If
192 | Next i
193 |
194 | If m_primaryKey = -1 Then
195 | Err.Raise StatusCode.ErrorNoPrimaryKeyDefined
196 | End If
197 | End Sub
198 |
--------------------------------------------------------------------------------
/src/Classes/WorkbookWebController.cls:
--------------------------------------------------------------------------------
1 | VERSION 1.0 CLASS
2 | BEGIN
3 | MultiUse = -1 'True
4 | END
5 | Attribute VB_Name = "WorkbookWebController"
6 | Attribute VB_GlobalNameSpace = False
7 | Attribute VB_Creatable = False
8 | Attribute VB_PredeclaredId = False
9 | Attribute VB_Exposed = False
10 | Implements IWebController
11 |
12 |
13 | Private Enum EntityRequestMode
14 | All
15 | ByKey
16 | Invalid
17 | End Enum
18 |
19 |
20 | Private Type EntityRequest
21 | Mode As EntityRequestMode
22 | Sheet As String
23 | key As String
24 | End Type
25 |
26 |
27 | Private Const UrlPrefix = "/workbook/"
28 |
29 | Private m_wrm As WorksheetRelationshipMapper
30 | Private m_jsonParser As JsonParser
31 |
32 |
33 | Private Sub Class_Initialize()
34 | Set m_wrm = New WorksheetRelationshipMapper
35 | Set m_jsonParser = New JsonParser
36 | End Sub
37 |
38 |
39 | Private Function IWebController_MatchesUrl(requestUrl As String) As Boolean
40 | IWebController_MatchesUrl = requestUrl Like UrlPrefix & "*"
41 | End Function
42 |
43 |
44 | Private Function IWebController_ProcessRequest(request As HttpRequest) As HttpResponse
45 | Dim requestHandled As Boolean
46 | requestHandled = False
47 |
48 | Dim response As HttpResponse
49 | Set response = New HttpResponse
50 |
51 | response.Headers.AddHeader "Content-Type", "application/json"
52 |
53 | Dim parsedRequest As EntityRequest
54 | parsedRequest = ParseRequestUrl(request.Url)
55 |
56 | Dim isJsonRequest As Boolean
57 | isJsonRequest = RequestContainsJsonData(request)
58 |
59 | If parsedRequest.Mode = All Then
60 | If request.RequestMethod = MethodGet Then
61 | Dim values As IJson
62 | Set values = m_wrm.All(parsedRequest.Sheet)
63 |
64 | response.StatusCode = 200
65 | response.body = values.ToJson()
66 |
67 | requestHandled = True
68 | ElseIf request.RequestMethod = MethodPost And isJsonRequest Then
69 | Dim postBody As JsonObject
70 | Set postBody = m_jsonParser.ParseObject(request.body)
71 |
72 | m_wrm.Insert parsedRequest.Sheet, postBody
73 |
74 | Dim responseValue As IJson
75 | Set responseValue = postBody
76 |
77 | Dim insertedId As JsonValue
78 | Set insertedId = postBody.GetProperty(m_wrm.PrimaryKeyName(parsedRequest.Sheet))
79 |
80 | response.Headers.AddHeader "Location", UrlPrefix & parsedRequest.Sheet & "/" & insertedId.value
81 | response.StatusCode = 201
82 | response.body = responseValue.ToJson()
83 |
84 | requestHandled = True
85 | End If
86 | ElseIf parsedRequest.Mode = ByKey Then
87 | If request.RequestMethod = MethodGet Then
88 | Dim getValue As IJson
89 | Set getValue = m_wrm.Find(parsedRequest.Sheet, parsedRequest.key)
90 |
91 | response.body = getValue.ToJson()
92 |
93 | ' this is a null value check in disguise
94 | If TypeName(getValue) = "JsonValue" Then
95 | response.StatusCode = 404
96 | Else ' type is JsonObject
97 | response.StatusCode = 200
98 | End If
99 |
100 | requestHandled = True
101 | ElseIf request.RequestMethod = MethodDelete Then
102 | Dim deleteValue As IJson
103 | Set deleteValue = m_wrm.Delete(parsedRequest.Sheet, parsedRequest.key)
104 |
105 | If deleteValue Is Nothing Then
106 | response.StatusCode = 404
107 | Else
108 | response.StatusCode = 200
109 | response.Headers.AddHeader "Content-Type", "application/json"
110 | response.body = deleteValue.ToJson()
111 | End If
112 |
113 | requestHandled = True
114 | ElseIf request.RequestMethod = MethodPut And isJsonRequest Then
115 | Dim putBody As JsonObject
116 | Set putBody = m_jsonParser.ParseObject(request.body)
117 |
118 | If m_wrm.Update(parsedRequest.Sheet, parsedRequest.key, putBody) Then
119 | response.StatusCode = 204
120 | Else
121 | response.StatusCode = 404
122 | End If
123 |
124 | requestHandled = True
125 | End If
126 | End If
127 |
128 | If Not requestHandled Then
129 | response.StatusCode = 404
130 | End If
131 |
132 | Set IWebController_ProcessRequest = response
133 | End Function
134 |
135 |
136 | Private Function ParseRequestUrl(requestUrl As String) As EntityRequest
137 | requestUrl = StringExtensions.Substring(requestUrl, Len(UrlPrefix))
138 |
139 | Dim urlParts
140 | urlParts = Split(requestUrl, "/")
141 |
142 | Dim partCount As Integer
143 | partCount = UBound(urlParts) + 1
144 |
145 | If partCount > 2 Then
146 | ParseRequestUrl.Mode = Invalid
147 | Exit Function
148 | End If
149 |
150 | ParseRequestUrl.Sheet = urlParts(0)
151 |
152 | If partCount = 1 Then
153 | ParseRequestUrl.Mode = All
154 | Exit Function
155 | End If
156 |
157 | ParseRequestUrl.key = Trim(urlParts(1))
158 |
159 | If Len(ParseRequestUrl.key) = 0 Then
160 | ParseRequestUrl.Mode = All
161 | Else
162 | ParseRequestUrl.Mode = ByKey
163 | End If
164 | End Function
165 |
166 |
167 | Private Function RequestContainsJsonData(request As HttpRequest) As Boolean
168 | RequestContainsJsonData = False
169 |
170 | For Each header In request.Headers.GetEnumerator
171 | Dim n As String
172 | n = LCase(header.name)
173 |
174 | Dim v As String
175 | v = LCase(header.value)
176 |
177 | If LCase(header.name) = "content-type" And (LCase(header.value) = "application/json" Or LCase(header.value) = "application/json;charset=utf-8") Then
178 | RequestContainsJsonData = True
179 | Exit Function
180 | End If
181 | Next header
182 | End Function
183 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | 
2 |
3 | [](https://github.com/michaelneu/webxcel)
4 | [](https://github.com/michaelneu/webxcel)
5 | [](https://github.com/michaelneu/webxcel)
6 | [](https://github.com/michaelneu/webxcel)
7 | [](https://github.com/michaelneu/webxcel)
8 | [](https://app.fossa.io/projects/git%2Bgithub.com%2Fmichaelneu%2Fwebxcel?ref=badge_shield)
9 |
10 | Webxcel creates a full-fledged RESTful web backend from your Microsoft Excel workbooks. It is written in 100% plain Visual Basic macros and comes with a lot of handy tools to help you build the next big thing.
11 |
12 |
13 | ## Features
14 |
15 | #### Rapid prototyping
16 |
17 | Build your web applications using the autogenerated RESTful CRUD endpoints and the static file server. Webxcel even supports mapping worksheet relationships, so you can model your table schema as flexible as you wish.
18 |
19 | To configure a new table, simply insert your column names in the first row of an empty sheet and make the cell of your primary key **bold**. References to other tables can be introduced using `fk_
` columns and foreign keys:
20 |
21 | 
22 |
23 | When accessing `GET /workbook/cities`, webxcel will return a fully mapped JSON object (response formatted for better readability):
24 |
25 | ```http
26 | HTTP/1.1 200 OK
27 | Content-Type: application/json
28 | Server: Microsoft Excel/16.0
29 | Content-Length: 200
30 | Connection: close
31 |
32 | [
33 | {
34 | "id": "1",
35 | "city": "Seattle",
36 | "states": {
37 | "short_name": "WA",
38 | "full_name": "Washington"
39 | }
40 | },
41 | {
42 | "id": "2",
43 | "city": "Springfield",
44 | "states": null
45 | }
46 | ]
47 | ```
48 |
49 |
50 | #### Batteries already included
51 |
52 | No need to spin up a cloud server or function-as-a-service provider, implement rich server side logic right in Microsoft Excel using the built-in tools you already know and love. Using Microsoft Excel's immersive charting, you can gather even deeper insights from your data.
53 |
54 |
55 | #### Scalable
56 |
57 | Webxcel supports scaling from a mere 10% to 400% for extreme detailed data insights. This makes it a perfect fit for small startups to global corporations. By default, webxcel projects are scaled 100%, but you can adjust this setting in the lower right corner of Microsoft Excel to fit your needs.
58 |
59 |
60 | #### Ready for deployment
61 |
62 | Many new devices come with Microsoft Office preinstalled, most of the time you won't have to do any setup at all. Deploying a project is as easy as dropping the file on the server and starting webxcel. Also backup is a no-brainer, simply copy and paste the project file to your backup location (e.g. a flash drive) and you're all set.
63 |
64 |
65 | #### Future proof with compatibility in mind
66 |
67 | Webxcel is built on Windows Sockets 2 and runs on any Microsoft Excel version starting from Microsoft Office 2007, but should work on any macro enabled setup.
68 |
69 |
70 | #### Hassle-free PHP
71 |
72 | Everybody hates PHP configurations. That's why webxcel ships with a PHP plugin that just works, no configuration needed. It's like serverless but better!
73 |
74 |
75 | #### Missing something?
76 |
77 | Check out the [features project](https://github.com/michaelneu/webxcel/projects/2) to get the latest news and ideas for webxcel, or file a [new issue](https://github.com/michaelneu/webxcel/issues/new).
78 |
79 |
80 | ## Getting started
81 |
82 | To quickstart development, check out the [example folder](example) for a simple todo app using React and webxcel.
83 |
84 |
85 | #### Creating new projects
86 |
87 | The `build.ps1` PowerShell script creates an empty webxcel project in `build/webxcel.xlsm`, which you can alter to create your table schema. You can also import the classes and modules by hand, but this will consume considerably more time since the import dialog only allows you to select one file at a time.
88 |
89 | In order for the build script to succeed, you may have to make a few changes to your Excel settings. Open the Trust Center in the options menu, select Macro Settings and check the following options:
90 | - Enable all macros
91 | - Trust access to the VBA project object model
92 |
93 | If you can't run the build script at all, use the following command to temporarily enable PowerShell scripts for the duration of your [PowerShell session](https://docs.microsoft.com/en-us/powershell/module/microsoft.powershell.security/set-executionpolicy?view=powershell-6#notes):
94 | ```powershell
95 | Set-ExecutionPolicy -ExecutionPolicy Unrestricted -Scope Process
96 | ```
97 |
98 | #### Running webxcel
99 |
100 | Webxcel can be started using either the `Main` sub through the developer ribbon or by assigning it to an interactive component like a button. Once started, webxcel will serve all static files located in the same directory as your project's `.xlsm`.
101 |
102 | During webxcel's runtime, Microsoft Excel will not respond. This is due to Visual Basic being executed on the main UI thread. As this is a known issue, webxcel creates a lockfile `.xlsm.lock`, which you can delete to gracefully shut down the server. You also could force-quit Microsoft Excel, but this might result in the port being blocked from further usage until a reboot (webxcel will raise the error [`ErrorSocketBind`](src/Modules/StatusCode.bas) whenever it can't bind to a specific port).
103 |
104 |
105 | ## Contributing
106 |
107 | To contribute, clone the repository, build an empty webxcel project and start hacking in the Visual Basic editor (Alt + F11). Once you've finished your contribution, export your classes or modules and create a [pull request](https://github.com/michaelneu/webxcel/compare). As Visual Basic is case-insensitive, please check your exported classes to minimize renaming commits (e.g. after introducing a new variable `Dim name` and the editor globally renamed `Name` to `name`).
108 |
109 |
110 | ## Is it any good?
111 |
112 | [Yes](https://news.ycombinator.com/item?id=3067434).
113 |
114 |
115 | ## License
116 |
117 | Webxcel is released under the [MIT license](LICENSE).
118 |
--------------------------------------------------------------------------------
/src/Classes/JsonParser.cls:
--------------------------------------------------------------------------------
1 | VERSION 1.0 CLASS
2 | BEGIN
3 | MultiUse = -1 'True
4 | END
5 | Attribute VB_Name = "JsonParser"
6 | Attribute VB_GlobalNameSpace = False
7 | Attribute VB_Creatable = False
8 | Attribute VB_PredeclaredId = False
9 | Attribute VB_Exposed = False
10 | Private m_null As JsonValue
11 |
12 |
13 | Private Sub Class_Initialize()
14 | Set m_null = New JsonValue
15 | m_null.value = Null
16 | End Sub
17 |
18 |
19 | Private Function ConsumeObject(ByVal text As String, ByRef counter As Long) As String
20 | Dim buffer As String
21 | Dim openBrackets As Long
22 | Dim openBraces As Long
23 |
24 | Dim inString As Boolean
25 | inString = False
26 |
27 | For counter = counter To Len(text)
28 | Dim char As String
29 | char = StringExtensions.CharAt(text, counter)
30 |
31 | buffer = buffer & char
32 |
33 | If char = """" Then
34 | inString = Not inString
35 | End If
36 |
37 | If Not inString Then
38 | Select Case char
39 | Case "["
40 | openBrackets = openBrackets + 1
41 |
42 | Case "]"
43 | openBrackets = openBrackets - 1
44 |
45 | Case "{"
46 | openBraces = openBraces + 1
47 |
48 | Case "}"
49 | openBraces = openBraces - 1
50 | End Select
51 | End If
52 |
53 | If openBrackets = 0 And openBraces = 0 Then
54 | ConsumeObject = buffer
55 | Exit Function
56 | End If
57 | Next counter
58 |
59 | Err.Raise StatusCode.ErrorMalformedJson
60 | End Function
61 |
62 |
63 | Public Function ParseObject(obj As String) As JsonObject
64 | If Not StringExtensions.StartsWith(obj, "{") Or Not StringExtensions.EndsWith(obj, "}") Then
65 | Err.Raise StatusCode.ErrorMalformedJson
66 | Exit Function
67 | End If
68 |
69 | Set ParseObject = New JsonObject
70 |
71 | obj = StringExtensions.Substring(obj, 1)
72 | obj = Left(obj, Len(obj) - 1)
73 |
74 | Dim propertyName As String
75 | Dim value As IJson
76 | Dim valueBuffer As String
77 | Dim i As Long
78 |
79 | For i = 1 To Len(obj)
80 | Dim char As String
81 | char = StringExtensions.CharAt(obj, i)
82 |
83 | Select Case char
84 | Case """"
85 | If Len(propertyName) > 0 Then
86 | Set value = ParseString(ConsumeString(obj, i))
87 |
88 | ParseObject.SetProperty propertyName, value
89 | propertyName = ""
90 | Else
91 | propertyName = ParseString(ConsumeString(obj, i)).value
92 | End If
93 |
94 | Case ":"
95 | If Len(propertyName) = 0 Then
96 | Err.Raise StatusCode.ErrorMalformedJson
97 | Exit Function
98 | End If
99 |
100 | Case "["
101 | Set value = ParseArray(ConsumeArray(obj, i))
102 |
103 | ParseObject.SetProperty propertyName, value
104 | propertyName = ""
105 |
106 | Case "{"
107 | Set value = ParseObject(ConsumeObject(obj, i))
108 |
109 | ParseObject.SetProperty propertyName, value
110 | propertyName = ""
111 |
112 | Case " ", vbTab, vbCr, vbLf, vbCrLf
113 | If Len(valueBuffer) > 0 And Len(propertyName) = 0 Then
114 | Err.Raise StatusCode.ErrorMalformedJson
115 | Exit Function
116 | End If
117 |
118 | Case ","
119 | If Len(valueBuffer) > 0 Then
120 | If Len(propertyName) = 0 Then
121 | Err.Raise StatusCode.ErrorMalformedJson
122 | Exit Function
123 | End If
124 |
125 | Set value = ParsePlainText(valueBuffer)
126 | ParseObject.SetProperty propertyName, value
127 |
128 | propertyName = ""
129 | valueBuffer = ""
130 | End If
131 |
132 | Case Else
133 | valueBuffer = valueBuffer & char
134 | End Select
135 | Next i
136 |
137 | If Len(valueBuffer) > 0 Then
138 | If Len(propertyName) = 0 Then
139 | Err.Raise StatusCode.ErrorMalformedJson
140 | Exit Function
141 | End If
142 |
143 | Set value = ParsePlainText(valueBuffer)
144 | ParseObject.SetProperty propertyName, value
145 | End If
146 | End Function
147 |
148 |
149 | Private Function ConsumeString(ByVal text As String, ByRef counter As Long) As String
150 | Dim buffer As String
151 | buffer = ""
152 |
153 | For counter = counter To Len(text)
154 | Dim char As String
155 | char = StringExtensions.CharAt(text, counter)
156 |
157 | buffer = buffer & char
158 |
159 | If char = """" And Len(buffer) > 1 Then
160 | ConsumeString = buffer
161 | Exit Function
162 | End If
163 | Next counter
164 |
165 | Err.Raise StatusCode.ErrorMalformedJson
166 | End Function
167 |
168 |
169 | Public Function ParseString(str As String) As JsonValue
170 | str = StringExtensions.Substring(str, 1)
171 | str = Left(str, Len(str) - 1)
172 |
173 | Set ParseString = New JsonValue
174 | ParseString.value = str
175 | End Function
176 |
177 |
178 | Private Function ConsumeArray(ByVal text As String, ByRef counter As Long) As String
179 | Dim buffer As String
180 | Dim openBrackets As Long
181 | Dim openBraces As Long
182 |
183 | Dim inString As Boolean
184 | inString = False
185 |
186 | For counter = counter To Len(text)
187 | Dim char As String
188 | char = StringExtensions.CharAt(text, counter)
189 |
190 | buffer = buffer & char
191 |
192 | If char = """" Then
193 | inString = Not inString
194 | End If
195 |
196 | If Not inString Then
197 | Select Case char
198 | Case "["
199 | openBrackets = openBrackets + 1
200 |
201 | Case "]"
202 | openBrackets = openBrackets - 1
203 |
204 | Case "{"
205 | openBraces = openBraces + 1
206 |
207 | Case "}"
208 | openBraces = openBraces - 1
209 | End Select
210 | End If
211 |
212 | If openBrackets = 0 And openBraces = 0 Then
213 | ConsumeArray = buffer
214 | Exit Function
215 | End If
216 | Next counter
217 |
218 | Err.Raise StatusCode.ErrorMalformedJson
219 | End Function
220 |
221 |
222 | Public Function ParseArray(arr As String) As JsonArray
223 | If Not StringExtensions.StartsWith(arr, "[") Or Not StringExtensions.EndsWith(arr, "]") Then
224 | Err.Raise StatusCode.ErrorMalformedJson
225 | Exit Function
226 | End If
227 |
228 | Set ParseArray = New JsonArray
229 |
230 | arr = StringExtensions.Substring(arr, 1)
231 | arr = Left(arr, Len(arr) - 1)
232 |
233 | Dim item As IJson
234 | Dim itemBuffer As String
235 | Dim i As Long
236 |
237 | For i = 1 To Len(arr)
238 | Dim char As String
239 | char = StringExtensions.CharAt(arr, i)
240 |
241 | Select Case char
242 | Case """"
243 | Set item = ParseString(ConsumeString(arr, i))
244 | ParseArray.AddItem item
245 |
246 | Case "["
247 | Set item = ParseArray(ConsumeArray(arr, i))
248 | ParseArray.AddItem item
249 |
250 | Case "{"
251 | Set item = ParseObject(ConsumeObject(arr, i))
252 | ParseArray.AddItem item
253 |
254 | Case " ", vbTab, vbCr, vbLf, vbCrLf
255 | If Len(valueBuffer) > 0 Then
256 | Err.Raise StatusCode.ErrorMalformedJson
257 | Exit Function
258 | End If
259 |
260 | Case ","
261 | If Len(itemBuffer) > 0 Then
262 | Set item = ParsePlainText(itemBuffer)
263 | ParseArray.AddItem item
264 |
265 | itemBuffer = ""
266 | End If
267 |
268 | Case Else
269 | itemBuffer = itemBuffer & char
270 | End Select
271 | Next i
272 |
273 | If Len(itemBuffer) > 0 Then
274 | Set item = ParsePlainText(itemBuffer)
275 | ParseArray.AddItem item
276 | End If
277 | End Function
278 |
279 |
280 | Private Function ParsePlainText(text As String) As JsonValue
281 | If LCase(text) = "null" Then
282 | Set ParsePlainText = m_null
283 | Else
284 | Dim textAsJsonValue As JsonValue
285 | Set textAsJsonValue = New JsonValue
286 | textAsJsonValue.value = text
287 |
288 | Set ParsePlainText = textAsJsonValue
289 | End If
290 | End Function
291 |
--------------------------------------------------------------------------------
/src/Classes/WorksheetRelationshipMapper.cls:
--------------------------------------------------------------------------------
1 | VERSION 1.0 CLASS
2 | BEGIN
3 | MultiUse = -1 'True
4 | END
5 | Attribute VB_Name = "WorksheetRelationshipMapper"
6 | Attribute VB_GlobalNameSpace = False
7 | Attribute VB_Creatable = False
8 | Attribute VB_PredeclaredId = False
9 | Attribute VB_Exposed = False
10 | Private m_tables As WorksheetTableCollection
11 |
12 |
13 | Private Sub Class_Initialize()
14 | Set m_tables = New WorksheetTableCollection
15 | End Sub
16 |
17 |
18 | Public Function PrimaryKeyName(sheetName As String) As String
19 | Dim table As WorksheetTable
20 | Set table = m_tables.FindTable(sheetName)
21 |
22 | PrimaryKeyName = table.PrimaryKey
23 | End Function
24 |
25 |
26 | Public Function All(sheetName As String) As JsonArray
27 | Set All = New JsonArray
28 |
29 | Dim table As WorksheetTable
30 | Set table = m_tables.FindTable(sheetName)
31 |
32 | For Each entry In table.Entries
33 | Dim obj As JsonObject
34 | Set obj = New JsonObject
35 |
36 | For Each column In table.Columns
37 | Dim val As JsonValue
38 | Set val = New JsonValue
39 |
40 | val.value = entry(column)
41 |
42 | obj.SetProperty column, val
43 | Next column
44 |
45 | All.AddItem MapEntryRelationships(obj)
46 | Next entry
47 | End Function
48 |
49 |
50 | Private Function MapEntryRelationships(entry As JsonObject) As JsonObject
51 | Set MapEntryRelationships = entry
52 |
53 | For Each property In entry.PropertyNames
54 | Dim val As JsonValue
55 | Set val = entry.GetProperty(property)
56 |
57 | If property Like "fk_*" Then
58 | Dim foreignTableName As String
59 | foreignTableName = StringExtensions.Substring(property, 3)
60 |
61 | Dim newVal As IJson
62 |
63 | If val.ContainsNull Then
64 | Set newVal = val
65 | Else
66 | Dim foreignObject As JsonObject
67 | Set foreignObject = New JsonObject
68 |
69 | Dim foreignTable As WorksheetTable
70 | Set foreignTable = m_tables.FindTable(foreignTableName)
71 |
72 | For Each foreignEntry In foreignTable.Entries
73 | If foreignEntry(foreignTable.PrimaryKey) = val.value Then
74 | Set foreignObject = New JsonObject
75 |
76 | For Each foreignColumn In foreignTable.Columns
77 | Dim foreignVal As JsonValue
78 | Set foreignVal = New JsonValue
79 | foreignVal.value = foreignEntry(foreignColumn)
80 |
81 | foreignObject.SetProperty foreignColumn, foreignVal
82 | Next foreignColumn
83 |
84 | Set foreignObject = MapEntryRelationships(foreignObject)
85 | End If
86 | Next foreignEntry
87 |
88 | If foreignObject Is Nothing Then
89 | Err.Raise StatusCode.ErrorInvalidForeignKeyUsed
90 | End If
91 |
92 | Set newVal = foreignObject
93 | End If
94 |
95 | entry.RemoveProperty property
96 | entry.SetProperty foreignTableName, newVal
97 | End If
98 | Next property
99 | End Function
100 |
101 |
102 | Public Function Find(sheetName As String, key) As IJson
103 | Dim table As WorksheetTable
104 | Set table = m_tables.FindTable(sheetName)
105 |
106 | Dim allValues As JsonArray
107 | Set allValues = All(sheetName)
108 |
109 | Dim i As Integer
110 | For i = 0 To allValues.count - 1
111 | Dim value As JsonObject
112 | Set value = allValues.GetItem(i)
113 |
114 | Dim valueAsJsonValue As JsonValue
115 | Set valueAsJsonValue = value.GetProperty(table.PrimaryKey)
116 |
117 | If valueAsJsonValue.value = key Then
118 | Set Find = value
119 | Exit Function
120 | End If
121 | Next i
122 |
123 | Dim nullValue As JsonValue
124 | Set nullValue = New JsonValue
125 | nullValue.value = Null
126 |
127 | Set Find = nullValue
128 | End Function
129 |
130 |
131 | Public Sub Insert(sheetName As String, item As JsonObject)
132 | Dim table As WorksheetTable
133 | Set table = m_tables.FindTable(sheetName)
134 |
135 | Dim itemToInsert
136 | Set itemToInsert = CreateObject("Scripting.Dictionary")
137 |
138 | Dim pkFound As Boolean
139 | pkFound = False
140 |
141 | For Each property In item.PropertyNames
142 | If property = table.PrimaryKey Then
143 | pkFound = True
144 | End If
145 |
146 | Dim propertyIsForeignKey As Boolean
147 | propertyIsForeignKey = False
148 |
149 | For Each column In table.Columns
150 | If "fk_" & property = column Then
151 | propertyIsForeignKey = True
152 | Exit For
153 | End If
154 | Next column
155 |
156 | If propertyIsForeignKey Then
157 | Dim foreignPropertyName As String
158 | foreignPropertyName = "fk_" & property
159 |
160 | Dim foreignTableName As String
161 | foreignTableName = property
162 |
163 | Dim foreignTable As WorksheetTable
164 | Set foreignTable = m_tables.FindTable(foreignTableName)
165 |
166 | Dim foreignItem As IJson
167 | Set foreignItem = item.GetProperty(property)
168 |
169 | If TypeName(foreignItem) = "JsonValue" Then
170 | Dim foreignItemAsValue As JsonValue
171 | Set foreignItemAsValue = foreignItem
172 |
173 | If foreignItemAsValue.ContainsNull Then
174 | itemToInsert.Add foreignPropertyName, ""
175 | Else
176 | Err.Raise StatusCode.ErrorInvalidForeignKeyUsed
177 | End If
178 | ElseIf TypeName(foreignItem) = "JsonObject" Then
179 | Dim foreignItemAsObject As JsonObject
180 | Set foreignItemAsObject = foreignItem
181 |
182 | Dim foreignItemContainsPk As Boolean
183 | foreignItemContainsPk = False
184 |
185 | For Each foreignProperty In foreignItemAsObject.PropertyNames
186 | If foreignProperty = foreignTable.PrimaryKey Then
187 | Dim foreignPkValue As JsonValue
188 | Set foreignPkValue = foreignItemAsObject.GetProperty(foreignProperty)
189 |
190 | itemToInsert.Add foreignPropertyName, foreignPkValue.value
191 | foreignItemContainsPk = True
192 | End If
193 | Next foreignProperty
194 |
195 | If foreignItemContainsPk Then
196 | Insert foreignTableName, foreignItemAsObject
197 | Else
198 | Err.Raise StatusCode.ErrorInvalidForeignKeyUsed
199 | End If
200 | Else
201 | Err.Raise StatusCode.ErrorInvalidForeignKeyUsed
202 | End If
203 | Else
204 | Dim value As JsonValue
205 | Set value = item.GetProperty(property)
206 |
207 | If value.ContainsNull Then
208 | itemToInsert.Add property, ""
209 | Else
210 | itemToInsert.Add property, value.value & ""
211 | End If
212 | End If
213 | Next property
214 |
215 | If Not pkFound Then
216 | Err.Raise StatusCode.ErrorDataDoesntContainPrimaryKey
217 | Exit Sub
218 | End If
219 |
220 | table.Insert itemToInsert
221 | End Sub
222 |
223 |
224 | Public Function Delete(sheetName As String, key As String) As JsonObject
225 | Dim table As WorksheetTable
226 | Set table = m_tables.FindTable(sheetName)
227 |
228 | Dim entry
229 | Set entry = table.Delete(key)
230 |
231 | If Not entry Is Nothing Then
232 | Dim deletedValue As JsonObject
233 | Set deletedValue = New JsonObject
234 |
235 | For Each column In table.Columns
236 | Dim val As JsonValue
237 | Set val = New JsonValue
238 |
239 | val.value = entry(column)
240 |
241 | deletedValue.SetProperty column, val
242 | Next column
243 |
244 | Set Delete = MapEntryRelationships(deletedValue)
245 | End If
246 | End Function
247 |
248 |
249 | Public Function Update(sheetName As String, key As String, item As JsonObject) As Boolean
250 | Dim table As WorksheetTable
251 | Set table = m_tables.FindTable(sheetName)
252 |
253 | Dim values
254 | Set values = CreateObject("Scripting.Dictionary")
255 |
256 | For Each property In item.PropertyNames
257 | Dim val As JsonValue
258 | Set val = item.GetProperty(property)
259 |
260 | If IsNull(val.value) Then
261 | values(property) = ""
262 | Else
263 | values(property) = val.value
264 | End If
265 | Next property
266 |
267 | Update = table.Update(key, values)
268 | End Function
269 |
--------------------------------------------------------------------------------