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