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
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