Solved Scraping Json from a web using VBA

[nector]

Sorry I'm just trying to consolidate my learning Json here, I'm trying to capture Json from a website and store it in Ms access database table , but I keep on getting an error that collection is empty , but whenever I hover around the VBA code I see the details there , any Idea where I'm going wrong?

Option Compare Database
Option Explicit

Private Sub CmdJson_Click()
Dim http As Object, JSON As Object, i As Integer
Dim item As Variant
Dim Z As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "http://jsonplaceholder.typicode.com/users", False
http.Send
Set rs = db.OpenRecordset("Contact", dbOpenDynaset, dbSeeChanges)
Set JSON = ParseJson(http.responseText)
i = 2
For Each item In JSON

    
    'Process data.
    Z = 1
    
        rs.AddNew
        rs("Id") = item("id")
        rs("Name") = item("name")
        rs("UserName") = item("username")
        rs("Email") = item("email")
        rs("Address") = item("address")("city")
        rs("phone") = item("phone")
        rs("WebSite") = item("website")
        rs("company") = item("company")("name")
        rs.Update
        Z = Z + 1
    Next
   MsgBox ("complete")
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set JSON = Nothing
    Set item = Nothing
End Sub

 

[cheekybuddha]

Please post the link to your thread where we can find the json.

 

[nector]

okay here the simple database attached , just see behind the unbound form

 

[isladogs]

Your field names in the code don't all match those in the Contacts table.
You don't have fields Name or Address.

 

[nector]

isladogs

Okay thanks let me match them one by one see if it will work

 

[nector]

Okay below is the correct answer if you are dealing MS Access:

Private Sub CmdJson_Click()
Dim http As Object, JSON As Object, i As Integer
Dim item As Variant
Dim Z As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "http://jsonplaceholder.typicode.com/users", False
http.Send
Set rs = db.OpenRecordset("Contact", dbOpenDynaset, dbSeeChanges)
Set JSON = ParseJson(http.responseText)
i = 2
For Each item In JSON

    
    'Process data.
    Z = 1
    
        rs.AddNew
        rs("Id") = item("id")
        rs("FirstName") = item("name")
        rs("username") = item("username")
        rs("email") = item("email")
        rs("street") = item("address")("street")
        rs("suite") = item("address")("suite")
        rs("city") = item("address")("city")
        rs("zipcode") = item("address")("zipcode")
        rs("lat") = item("address")("geo")("lat")
        rs("lng") = item("address")("geo")("lng")
        rs("phone") = item("phone")
        rs("WebSite") = item("website")
        rs("catchPhrase") = item("company")("catchPhrase")
        rs("bs") = item("company")("bs")
        rs.Update
        Z = Z + 1
    Next
   MsgBox ("complete")
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set JSON = Nothing
    Set item = Nothing
End Sub

 

[isladogs]

Not quite complete. You omitted the line

rs("Company") = item("company")("name")

You also have no protection against the same data being entered repeatedly. Make id the PK field and omit IDs
Then add error handling to handle error 3022 in case of duplicate records being processed

Finally the line i=2 serves no purpose - delete it. Similarly for the record count using Z unless you add this to the end message

This is my amended version:

Private Sub CmdJson_Click()
Dim http As Object, JSON As Object, i As Integer
Dim item As Variant
Dim Z As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset

On Error GoTo Err_Handler

Set db = CurrentDb
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "http://jsonplaceholder.typicode.com/users", False
http.Send
Set rs = db.OpenRecordset("Contact", dbOpenDynaset, dbSeeChanges)
Set JSON = ParseJson(http.responseText)
'i = 2 '<==REMOVED

Z = 0
For Each item In JSON
    'Process data.
        rs.AddNew
        rs("Id") = item("id")
        rs("FirstName") = item("name")
        rs("username") = item("username")
        rs("email") = item("email")
        rs("street") = item("address")("street")
        rs("suite") = item("address")("suite")
        rs("city") = item("address")("city")
        rs("zipcode") = item("address")("zipcode")
        rs("lat") = item("address")("geo")("lat")
        rs("lng") = item("address")("geo")("lng")
        rs("phone") = item("phone")
        rs("WebSite") = item("website")
        rs("Company") = item("company")("name") '<==ADDED
        rs("catchPhrase") = item("company")("catchPhrase")
        rs("bs") = item("company")("bs")
        Z = Z + 1
        rs.Update
        
    Next
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set JSON = Nothing
    Set item = Nothing
    
    'show message
    If Z > 0 Then
        MsgBox "Import completed." & vbCrLf & _
            Z & " records have been imported", vbInformation, "Import succeeded"
    End If
    
Exit_Handler:
    Exit Sub
    
Err_Handler:
    If Err = 3022 Then
        'duplicate records
        MsgBox "No additional records have been imported", vbInformation, "Import failed"
    Else
        MsgBox "Error " & Err & " in cmdJson_Click: " & Err.Description
    End If
    Resume Exit_Handler
        
End Sub

 

[nector]

Thank you so much for trying to help with more secure code , but it has an error message.

 

[isladogs]

Your table may be different to mine. On which line does the error occur?
It works for me. See attached.

 

[nector]

Many thanks to you isladogs you have not only taught me the best way to handle this but also others as well. I will come later for the parent table I'm sure you have realized that, that details below to the child table, I thought of starting with the child table the data is complex while the parent has only three controls which I will show in a ne thread to avoid confusion. Once again many thanks to you
Regards
Chris

 

[Josef P.]

A general comment on your last JSON threads:

In principle, you always have such an approach, which I think you could also consider in the code:

1. Get JSON-String JsonString = GetJsonFrom....(...)
   • read a text file => Function GetJsonFromFile(Byval FilePath as string) as String
   • get from Web: REST,.... => Function GetJsonFromHttp(Byval URL as String, ...) as String
   • ....
2. parse the string with JsonConverter (VBA-JSON) => Set Json = JsonConverter.ParseJson(JsonString)
3. process the dictionary/collection instances with the JSON content.
   • Save to table => Sub InsertJsonToTabXzy(Byval Json as Object)
   • ....

 

[isladogs]

Yes I realised you had flattened the data into one table. Whilst that’s ok if there is only one address and company for each person, it’s no use if that’s not the case.
Handling sub arrays is more complex. The same approach can be used but you need to split into several recordsets, one each for the main part and each subarray. This adds to the time needed to process each file.
My JSON analyzer was mainly designed for those who need to work with a lot of complex JSON files with varying structures.
In fact I ran this online file through my analyzer first, then realized you hadn’t split the data.
However, my app may not be worth the cost for those like yourself who only need to do this type of import occasionally or indeed for those who want to do everything involved for themselves.