Sample_TDRestAPI

Option Compare Database
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub getSampleData()
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim xmlhttp As Object
    Dim restAPI As String
    Dim i, k As Long
    Dim objJSON As Object
    Dim jobId As Long
    Dim tsvStr As String
    Dim buf, cols
    
    Const BASE_URL As String = "http://api.treasuredata.com"
    Const APIKEY As String = "TD1 <YOUR TD APIKEY>"
    Const TDDBNAME As String = "sample_datasets"
    Const issuesQueries As String = "/v3/job/issue/hive/" & TDDBNAME
    Const jobStatus As String = "/v3/job/status/"
    Const jobResult As String = "/v3/job/result/"
           
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    With xmlhttp
        .Open "POST", BASE_URL & issuesQueries, False
        .setRequestHeader "AUTHORIZATION", APIKEY
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "&query=select time,user,host,path,referer,code,agent,size,method from www_access limit 100"
    End With
    
    getJSON xmlhttp.responseText, objJSON
    jobId = objJSON.job_id
    
    MsgBox jobId
    
    i = 0
    Do
        Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
        With xmlhttp
            .Open "GET", BASE_URL & jobStatus & jobId, False
            .setRequestHeader "AUTHORIZATION", APIKEY
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send
        End With
        
        getJSON xmlhttp.responseText, objJSON
        If objJSON.statusinfo = "success" Or objJSON.statusinfo = "error" Then Exit Do
        
        Sleep 5000

        i = i + 1
        If i > 20 Then Exit Do
    Loop While True
    
    Set cnn = Application.CurrentProject.Connection
    Set rs = New ADODB.Recordset
    rs.Open "www_access", cnn, adOpenDynamic, adLockOptimistic
    
    If objJSON.statusinfo = "success" Then
        Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
        With xmlhttp
            .Open "GET", BASE_URL & jobResult & jobId & "?format=tsv", False
            .setRequestHeader "AUTHORIZATION", APIKEY
            .setRequestHeader "Content-Type", "text/plain"
            .send
             tsvStr = .responseText
        End With
        
        buf = Split(tsvStr, vbLf)
        For k = 0 To UBound(buf)
            If buf(k) <> "" Then
                cols = Split(buf(k), vbTab)
                With rs
                    .AddNew
                    'time,user,host,path,referer,code,agent,size,method
                    If cols(0) <> "" Then .Fields("time") = cols(0)
                    If cols(1) <> "" Then .Fields("user") = cols(1)
                    If cols(2) <> "" Then .Fields("host") = cols(2)
                    If cols(3) <> "" Then .Fields("path") = cols(3)
                    If cols(4) <> "" Then .Fields("referer") = cols(4)
                    If cols(5) <> "" Then .Fields("code") = cols(5)
                    If cols(6) <> "" Then .Fields("agent") = cols(6)
                    If cols(7) <> "" Then .Fields("size") = cols(7)
                    If cols(8) <> "" Then .Fields("method") = cols(8)
                    .Update
                End With
            End If
        Next k
    End If
    
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
    
    
End Sub

' Convert from String to JSON
Sub getJSON(str As String, objJSON As Object)
    Dim js As Object
    str = Replace(str, "status", "statusinfo")
     
    Set js = CreateObject("ScriptControl")
    js.Language = "JScript"
    js.AddCode "function jsonParse(str) { return eval('(' + str + ')'); };"
     
    Set objJSON = js.codeobject.jsonParse(str)
End Sub