Update Nov2017
UPDATE: parse.com as now been closed and moved to parseplatform.org. I will update the content of this page an move the back-end to this platform
parse.com – nosql database for VBA, describes how to use this class to be able to use parse.com directly from VBA. Here’s the details of the implementation.
The code
|
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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
Option Explicit ' a VBA class for parse.com ' v1.2 Private pBrowser As cBrowser Private pPackage As cJobject Private pClass As String Private pApplicationHeaders As cJobject Private pSalt As String Private pBatch As cJobject Private pBatchPoint As String Private pBatchMode As Boolean Private pEndPoint As String Private pClassPoint As String Private pBatchMax As Long Public Property Get parseClass() As String parseClass = pClass End Property Public Property Let parseClass(p As String) pClass = p End Property Public Function resultsLength(Optional job As cJobject = Nothing) As Long Dim j As cJobject Set j = job If j Is Nothing Then Set j = jObject End If resultsLength = j.child("results").children.count If job Is Nothing Then j.tearDown End If End Function Public Function count(Optional queryJob As cJobject = Nothing, Optional queryParams As cJobject = Nothing) As Long count = 0 With getCount(queryJob, queryParams) If .isOk Then With .jObject count = .child("count").value .tearDown End With End If End With End Function Public Property Get self() As cParseCom Set self = Me End Property Public Property Get jObject() Set jObject = JSONParse(browser.Text) End Property Public Property Get browser() Set browser = pBrowser End Property Public Property Get isOk() As Boolean isOk = False If pBrowser.isOk Or (pBrowser.status = 0 And pBatchMode) Then If Not pBatchMode Then isOk = True Else ' need to check for errors in all the flushed batch With jObject isOk = .find("error") Is Nothing .tearDown End With End If End If End Property Public Function init(whichClass As String, _ Optional credentialsEntry As String = "parse", _ Optional scopeEntry As String = "rest", _ Optional restAPIKey As String = vbNullString, _ Optional clientKey As String = vbNullString) As cParseCom Set pPackage = getParseCredentials(credentialsEntry, scopeEntry, restAPIKey, clientKey) If pPackage Is Nothing Then Exit Function End If Set pApplicationHeaders = getApplicationHeaders pClass = whichClass Set init = Me End Function Public Function getObjectById(id As String) As cParseCom Set getObjectById = getStuff("/" & id) End Function Public Function getObjectsByQuery(Optional queryJob As cJobject = Nothing, _ Optional queryParams As cJobject = Nothing) As cParseCom Set getObjectsByQuery = getStuff(vbNullString, constructQueryString(queryJob, queryParams)) End Function Private Function constructQueryString(Optional queryJob As cJobject = Nothing, _ Optional queryParams As cJobject = Nothing) As String Dim qString As String, t As cStringChunker, job As cJobject ' set up parameters Set t = New cStringChunker If Not queryParams Is Nothing Then For Each job In queryParams.children t.add(job.key).add("=").add(job.toString).add ("&") Next job End If ' set up query string If Not queryJob Is Nothing Then t.add URLEncode("where=" & JSONStringify(queryJob)) End If qString = vbNullString t.chopIf "&" If t.size > 0 Then qString = "?" & t.content End If Set t = Nothing constructQueryString = qString End Function Private Function mergeParameters(Optional queryParams As cJobject = Nothing, Optional addParams As cJobject = Nothing) As cJobject Dim job As cJobject ' start with the given params If Not queryParams Is Nothing Then ' take a copy Set job = JSONParse(queryParams.stringify) End If ' add some more If Not addParams Is Nothing Then If job Is Nothing Then Set job = New cJobject job.init Nothing End If job.merge addParams End If Set mergeParameters = job End Function Public Function getCount(Optional queryJob As cJobject = Nothing, Optional queryParams As cJobject = Nothing) As cParseCom Set getCount = getStuff(vbNullString, _ constructQueryString(queryJob, mergeParameters(queryParams, JSONParse("{'count':1,'limit':0}")))) End Function Public Function createObject(addJob As cJobject) As cParseCom Set createObject = postStuff(vbNullString, addJob) End Function Public Function updateObjects(Optional queryJob As cJobject = Nothing, _ Optional updateJob As cJobject = Nothing, Optional queryParameters As cJobject = Nothing) As cParseCom ' does a query, then update all matching Dim queryResponse As cJobject, skip As Long, jobSkip As cJobject, number As Long skip = 0 Set jobSkip = JSONParse("{'skip':0}") ' we'll just use the default limit Do With getObjectsByQuery(queryJob, mergeParameters(queryParameters, jobSkip)).jObject ' this is how many were returned this time number = resultsLength(.self) ' if there were any then do soemthing with it If number > 0 Then ' skip what we've already had skip = skip + number jobSkip.child("skip").value = skip ' update the contents of the query we just did updateObjectsPart .self, updateJob End If ' clear out these results .tearDown End With ' if there were any errors or there's no more to do then exit Loop While isOk And number > 0 Set updateObjects = Me End Function Private Function updateObjectsPart(queryResponse As cJobject, updateJob As cJobject) As cParseCom Dim job As cJobject ' any matching get the same update If isOk And Not queryResponse Is Nothing Then With queryResponse For Each job In .child("results").children postStuff job.child("objectId").value, updateJob, "PUT" Next job .tearDown End With End If Set updateObjectsPart = Me End Function Public Function deleteObjects(Optional queryJob As cJobject = Nothing) As cParseCom Dim queryResponse As cJobject ' query is limited, so we need to keep going until no results While self.count > 0 Set queryResponse = getObjectsByQuery(queryJob).jObject deleteObjectsPart queryResponse If Not isOk Then MsgBox "failed to flush:" & browser.status & ":" & browser.Text Exit Function End If queryResponse.tearDown Wend Set deleteObjects = Me End Function Private Function deleteObjectsPart(queryResponse As cJobject) As cParseCom ' does a query, then update all matching Dim job As cJobject ' any matching get deleted If isOk Then For Each job In queryResponse.child("results").children deleteObject job.child("objectId").value Next job End If Set deleteObjectsPart = Me End Function Public Function deleteObject(id As String) As cParseCom If pBatchMode Then postStuff id, , "DELETE" Else Set deleteObject = getStuff("/" & id, , "DELETE") End If End Function Public Function postStuff(what As String, Optional data As cJobject = Nothing, _ Optional method As String = "POST") As cParseCom If pBatchMode Then If isEmptyBatchNeeded Then flush addToBatch method, pClassPoint & parseClass & "/" & what, data Else doPost pEndPoint & pClassPoint & parseClass & "/" & what, data, method End If Set postStuff = Me End Function Public Function getStuff(what As String, Optional params As String = vbNullString, Optional method As String = "GET") As cParseCom Dim post As String 'always need to flush before a get flush pBrowser.httpGET pEndPoint & pClassPoint & parseClass & what & params, , , , , , pApplicationHeaders, method Set getStuff = Me End Function Private Function doPost(url As String, Optional data As cJobject = Nothing, Optional method As String = "POST") As cParseCom ' called when we need to issue a get Dim dString As String If Not data Is Nothing Then dString = data.stringify pBrowser.httpPost url, dString, True, , pApplicationHeaders, method Set doPost = Me End Function Private Function clearDown(o As Object) As cParseCom If Not o Is Nothing Then o.tearDown Set o = Nothing End If Set clearDown = Me End Function Private Function isEmptyBatchNeeded() As Boolean ' there's a maximum to how many we can batch at once isEmptyBatchNeeded = False If Not pBatch Is Nothing Then isEmptyBatchNeeded = (pBatch.child("requests").children.count >= pBatchMax) End Function Private Function addToBatch(method As String, path As String, Optional body As cJobject = Nothing) If pBatch Is Nothing Then Set pBatch = New cJobject pBatch.init Nothing End If ' first in? If Not pBatch.hasChildren Then pBatch.add("requests").addArray End If With pBatch.child("requests").add If Right(path, 1) = "/" Then path = left(path, Len(path) - 1) .add "method", method .add "path", path If Not body Is Nothing Then With .add("body") .append body End With End If End With Set addToBatch = Me End Function Public Function batch(Optional batchItUp As Boolean = True) As cParseCom ' use this to set up batching. if any outstanding it will clear it if changing batching mode If Not batchItUp Then flush End If pBatchMode = batchItUp Set batch = Me End Function Public Property Get batchMode() As Boolean batchMode = pBatchMode End Property Public Function flush() ' been storing stuff up If Not pBatch Is Nothing Then If (pBatch.hasChildren) Then doPost pEndPoint & pBatchPoint, pBatch, "POST" If Not isOk Then MsgBox "failed to flush:" & browser.status & ":" & browser.Text End If pBatch.tearDown End If Set pBatch = Nothing End If Set flush = Me End Function Public Sub tearDown() clearDown pBrowser clearDown pPackage clearDown pApplicationHeaders clearDown pBatch End Sub Private Sub Class_Initialize() Set pBrowser = New cBrowser pEndPoint = "https://api.parse.com" pClassPoint = "/1/classes/" pBatchPoint = "/1/batch" pSalt = "xLiberation" pBatchMode = False pBatchMax = 50 End Sub Private Function getParseCredentials(entry As String, scope As String, _ Optional restAPIKey As String = vbNullString, _ Optional clientKey As String = vbNullString) As cJobject Set pPackage = getRegistryPackage(entry, scope) If pPackage Is Nothing Then If (restAPIKey = vbNullString Or clientKey = vbNullString) Then MsgBox ("First time you need to provide keys") Exit Function End If Set pPackage = New cJobject With pPackage.init(Nothing) .add "scopeEntry", scope .add "authFlavor", entry .add "restAPIKey", restAPIKey .add "applicationID", clientKey End With setRegistryPackage End If Set getParseCredentials = pPackage End Function Private Function getApplicationHeaders() As cJobject Dim job As cJobject, a As cJobject Set job = New cJobject With job.init(Nothing) .add "X-Parse-Application-Id", pPackage.child("applicationID").value .add "X-Parse-REST-API-Key", pPackage.child("restAPIKey").value End With Set getApplicationHeaders = job End Function '" ---- registry ----- '" in registry entries, the values are encrypted useing the salt '" the structure is '" xLiberation/parseAuth/scope - json pPackage values Private Function getRegistryPackage(authFlavor As String, scopeEntry As String) As cJobject Dim s As String s = GetSetting("xLiberation", _ authFlavor, _ scopeEntry) If (s <> vbNullString) Then Set getRegistryPackage = JSONParse(decrypt(s)) End Function Private Function setRegistryPackage() As cJobject Dim s As String s = JSONStringify(pPackage) SaveSetting "xLiberation", _ pPackage.child("authFlavor").value, _ pPackage.child("scopeEntry").value, _ encrypt(s) End Function Private Function encrypt(s As String) As String ' " uses capicom encrypt = encryptMessage(s, pSalt) End Function Private Function decrypt(s As String) As String ' " uses capicom decrypt = decryptMessage(s, pSalt) End Function |
For help and more information join our forum, follow the blog or follow me on Twitter