parse.com api class for VBA

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