Solved Storing received Json from the internet into Parent table & child table at one go (1 Viewer)

[nector]

Although I have an option to recapture the received Json manually from the report into both the parent and child tables, but I see this option to be somehow risk because wrong data can be easily captured we are human and this is also alot of work

So, in view of the above I have struggled to figure out how to do the insert in two tables at one go, below is my VBA code I have not yet tested it I will do that at 22:00 hours today when I have enough time. My worries are stated below, and so any possible correction will be appreciated.

(1) Opening the two record sets correctly (rs for the header & rst for the details)
(2) Iterating through the fields for the header & details as per response received , see response below or last page
(3) What if there four purchases invoices details received can this method save them individually NOT combined , preferably individually
(4) How to grab the parent table primary key and insert it in the child table as a foreign key, this way the record will remain linked


VBA CODE

Private Sub CmdlocalPurchasesSearch_Click()
On Error GoTo Err_Handler
Dim n As Integer
Dim z As Integer
Dim JSON As Object
Dim item As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim Request As Object
Dim strData As String
Dim stUrl As String
Dim Response As String
Dim requestBody As String
Dim Company As New Dictionary
Set Company = New Dictionary

stUrl = "http://hostname:8080/nector/trnsPurchase/selectTrnsPurchase"
Set Request = CreateObject("MSXML2.XMLHTTP")
Company.Add "tpin", "1002623668"
Company.Add "bhfId", "000"
Company.Add "lastReqDt", Format((Me.txtlastdateLocalPurchases), "YYYYMMDD000000")
strData = JsonConverter.ConvertToJson(Company, Whitespace:=3)
requestBody = strData
    With Request
        .Open "POST", stUrl, False
        .setRequestHeader "Content-type", "application/json"
        .send requestBody
        Response = .ResponseText
    End With
If Request.Status = 200 Then
MsgBox Request.ResponseText, vbCritical, "Internal Audit Manager"

Set rst = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)
Set rs = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)
Set JSON = ParseJson(Request.ResponseText)

'i = 1
For Each item In JSON("data")("saleList")

'Process data.
z = 1
'Purchases header details to saved in the parent table
rs.AddNew
rs("OurTPIN") = item("spplrTpin")
rs("bhfId") = item("spplrBhfId")
rs("spplrInvcNo") = item("spplrInvcNo")
rs("rcptTyCd") = item("rcptTyCd")
rs("pmtTyCd") = item("pmtTyCd")
rs("cfmDt") = item("cfmDt")
rs("pchsDt") = item("salesDt")
rs("wrhsDt") = item("stockRlsDt")
rs("totItemCnt") = item("totItemCnt")
rs("taxblAmtA") = item("taxblAmtA")
rs("taxblAmtB") = item("taxblAmtB")
rs("taxblAmtC1") = item("taxblAmtC1")
rs("taxblAmtC2") = item("taxblAmtC2")
rs("taxblAmtC3") = item("taxblAmtC3")
rs("taxblAmtD") = item("taxblAmtD")
rs("taxRtA") = item("taxRtA")
rs("taxRtB") = item("taxRtB")
rs("taxRtC1") = item("taxRtC1")
rs("taxRtC2") = item("taxRtC2")
rs("taxRtC3") = item("taxRt.C3")
rs("taxRtD") = item("taxRtD")
rs("taxRtB") = item("taxRtB")
rs("taxAmtA") = item("taxAmtA")
rs("taxAmtB") = item("taxAmtB")
rs("taxAmtC1") = item("taxAmtC1")
rs("taxAmtC2") = item("taxAmtC2")
rs("taxAmtC3") = item("taxAmtC3")
rs("taxAmtD") = item("taxAmtD")
rs("totTaxblAmt") = item("totTaxblAmt")
rs("totTaxAmt") = item("totTaxAmt")
rs("totAmt") = item("totAmt")
rs("remark") = item("remark")
rs("regrNm") = "Admin"
rs("regrId") = "Admin"
rs("modrNm") = "Admin"
rs("modrId") = "Admin"
rs.Update
'Purchases details lines to saved in the child table
rst.AddNew
rst("itemSeq") = item("itemList")("itemSeq")
rst("itemCd") = item("itemList")("itemCd")
rst("itemClsCd") = item("itemList")("itemClsCd")
rst("itemNm") = item("itemList")("itemNm")
rst("bcd") = item("itemList")("bcd")
rst("pkg") = item("itemList")("pkg")
rst("qtyUnitCd") = item("itemList")("qtyUnitCd")
rst("qty") = item("itemList")("qty")
rst("prc") = item("itemList")("prc")
rst("splyAmt") = item("itemList")("splyAmt")
rst("dcRt") = item("itemList")("dcRt")
rst("dcAmt") = item("itemList")("dcAmt")
rst("taxblAmt") = item("itemList")("taxblAmt")
rst("taxAmt") = item("itemList")("vatAmt")
rst("totAmt") = item("itemList")("totAmt")
rst("PurchID") = DLast("PurchID", "tblpurchases")
rst.Update
        z = z + 1
    Next
rs.Close
rst.Close
Set rs = Nothing
Set rst = Nothing
Set db = Nothing
Set JSON = Nothing
Set item = Nothing
Exit Sub
End If
Exit_CmdlocalPurchasesSearch_Click:
Exit Sub
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_CmdlocalPurchasesSearch_Click
End Sub

Below is the response Json body expected from the internet :

Response

{
  "resultCd": "000",
  "resultMsg": "It is succeeded",
  "resultDt": "20240308182347",
  "data": {
    "saleList": [
      {
        "spplrTpin": "1002623668",
        "spplrNm": "CHRISTOPHER HANKWEMBO",
        "spplrBhfId": "000",
        "spplrInvcNo": 610,
        "rcptTyCd": "S",
        "pmtTyCd": "01",
        "cfmDt": "2024-03-08 09:16:08",
        "salesDt": "20240308",
        "stockRlsDt": "2024-03-08 09:16:08",
        "totItemCnt": 1,
        "taxblAmtA": 0,
        "taxblAmtB": 360,
        "taxblAmtC1": null,
        "taxblAmtC2": null,
        "taxblAmtC3": 0,
        "taxblAmtD": 0,
        "taxblAmtRvat": null,
        "taxblAmtE": null,
        "taxblAmtF": null,
        "taxblAmtIpl1": null,
        "taxblAmtIpl2": null,
        "taxblAmtTl": null,
        "taxblAmtEcm": null,
        "taxblAmtExeeg": null,
        "taxblAmtTot": null,
        "taxRtA": 16,
        "taxRtB": 16,
        "taxRtC1": null,
        "taxRtC2": null,
        "taxRtC3": null,
        "taxRtD": 0,
        "taxRtE": null,
        "taxRtRvat": null,
        "taxRtF": null,
        "taxRtIpl1": null,
        "taxRtIpl2": null,
        "taxRtTl": null,
        "taxRtEcm": null,
        "taxRtExeeg": null,
        "taxRtTot": null,
        "taxAmtA": 0,
        "taxAmtB": 0,
        "taxAmtC1": null,
        "taxAmtC2": null,
        "taxAmtC3": 49.66,
        "taxAmtD": 0,
        "taxAmtRvat": null,
        "taxAmtE": null,
        "taxAmtF": null,
        "taxAmtIpl1": null,
        "taxAmtIpl2": null,
        "taxAmtTl": null,
        "taxAmtEcm": null,
        "taxAmtExeeg": null,
        "taxAmtTot": null,
        "totTaxblAmt": 300,
        "totTaxAmt": 49.66,
        "totAmt": 300,
        "remark": null,
        "itemList": [
          {
            "itemSeq": 1,
            "itemCd": "ZM2NTU00000014",
            "itemClsCd": "40000014",
            "itemNm": "CEMENT",
            "bcd": null,
            "pkgUnitCd": "NT",
            "pkg": 1,
            "qtyUnitCd": "U",
            "qty": 2,
            "prc": 150,
            "splyAmt": 150,
            "dcRt": 0,
            "dcAmt": 0,
            "vatCatCd": "B",
            "iplCatCd": null,
            "tlCatCd": null,
            "exciseTxCatCd": null,
            "taxblAmt": 360,
            "vatAmt": 49.66,
            "iplAmt": null,
            "tlAmt": null,
            "exciseTxAmt": null,
            "totAmt": 360
          }
        ]
      },

 

[arnelgp]

many times have you post same json and still you have not learned from them?

 

[gemma-the-husky]

Really, what I would do is extract the data into inbound staging tables, with a header record, and multiple line records, but you will need a way to link the headers to the details.

If the data does not contain links then you will need to process the file sequentially, record at a time. So get a record, process the header, then process the items array. If the data has a field that links the items to the correct headers, then you could first extract just the headers, then just the lines. The second way might be easier to automate as a process, but it depends on the structure of the file.

Having extracted the data from the file, then decide how you want to incorporate the new data into your actual data.

Json or XML may give you a well formed starting point, but it won't automatically know how you want to process the data, or do it for you.

For instance your header has a "total taxable amount". You possibly won't need that, other than to check that the sum of the line values reconciles to the total in the header, but that depends on the structure of your actual data.

I presume at some point, for instance you need to match the supplier name to a supplier account number, and store that value rather than the supplier name in the supplier invoice table. It still all needs a deal of thought and analysis.

For instance, do you know every tag that might appear in the file? Are there some new tags that only appear occasionally?

 

[nector]

I have updated the code above and now its working okay, except how to force the created primary keys to also appear in the child table as foreign key

This is only picking the last record I want to from the most current to last

DLast("PurchID", "tblpurchases")

 

[cheekybuddha]

Just grab the PK:

' ...
' Declare a variable outside the loop to store the PK
  Dim PK As Long
' ...
rs("modrNm") = "Admin"
rs("modrId") = "Admin"
rs.Update
PK = rs("NameOfPKField")   '  <-- Add this line
'Purchases details lines to saved in the child table
rst.AddNew
' ...
rst("PurchID") = PK    ' <-- Change this line
' ...

 

[nector]

Thank you so much

cheekybuddha​

This works , but saves only the first PK , I have sometime 5 invoices to save .

 

[cheekybuddha]

I'm guessing that invoices are the rs recordset and invoice items are the rst recordset.
It should pick up the PK for every new rs record added.
But it doesn't look like you are looping the itemList to add each item per saleList record (if there is more than one)

 

[nector]

I'm guessing that invoices are the rs recordset and invoice items are the rst recordset.
It should pick up the PK for every new rs record added.

Yes that is correct

See below

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim PK As Long
Set db = CurrentDb
Set rs = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)
Set rst = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)


Set JSON = ParseJson(Request.ResponseText)

'i = 1
For Each item In JSON("data")("saleList")
  
'Process data.

'Purchases header details to saved in the parent table
rs.AddNew
rs("OurTPIN") = item("spplrTpin")
rs("bhfId") = item("spplrBhfId")
rs("spplrInvcNo") = item("spplrInvcNo")
rs("rcptTyCd") = item("rcptTyCd")
rs("pmtTyCd") = item("pmtTyCd")
rs("cfmDt") = item("cfmDt")
rs("pchsDt") = CDate(Format$((item("salesDt")), "00/00/00"))
rs("wrhsDt") = item("stockRlsDt")
rs("totItemCnt") = item("totItemCnt")
rs("taxblAmtA") = item("taxblAmtA")
rs("taxblAmtB") = item("taxblAmtB")
rs("taxRtA") = item("taxRtA")
rs("taxRtB") = item("taxRtB")
rs("taxRtD") = item("taxRtD")
rs("taxRtB") = item("taxRtB")
rs("taxAmtA") = item("taxAmtA")
rs("taxAmtB") = item("taxAmtB")
rs("taxAmtC1") = item("taxAmtC1")
rs("taxAmtC2") = item("taxAmtC2")
rs("taxAmtD") = item("taxAmtD")
rs("totTaxblAmt") = item("totTaxblAmt")
rs("totTaxAmt") = item("totTaxAmt")
rs("totAmt") = item("totAmt")
rs("remark") = item("remark")
rs("regrNm") = "Admin"
rs("regrId") = "Admin"
rs("modrNm") = "Admin"
rs("modrId") = "Admin"
rs.Update
Next
'Purchases details to saved in the child table

z = 1

For Each item In JSON("data")("saleList")
rst.AddNew
rst("itemSeq") = item("itemSeq")
rst("itemCd") = item("itemCd")
rst("itemClsCd") = item("itemClsCd")
rst("itemNm") = item("itemNm")
rst("bcd") = item("bcd")
rst("pkg") = item("pkg")
rst("qtyUnitCd") = item("qtyUnitCd")
rst("qty") = item("qty")
rst("prc") = item("prc")
rst("splyAmt") = item("splyAmt")
rst("dcRt") = item("dcRt")
rst("dcAmt") = item("dcAmt")
rst("taxblAmt") = item("taxblAmt")
rst("taxAmt") = item("vatAmt")
rst("totAmt") = item("totAmt")
rst("PurchID") = rs("PurchID")
rst.Update

Next
    
MsgBox "Please note that data import is now done", vbCritical, "Done!"
rs.Close
rst.Close
Set rs = Nothing
Set rst = Nothing
Set db = Nothing
Set JSON = Nothing
Set item = Nothing

 

[cheekybuddha]

You are looping the items outside the individual saleList loop, so effectively you are only grabbing the items for the last purchase. Also, your second loop seems to loop the same as the first!!! For Each item In JSON("data")("saleList")

Do you have Option Explicit declared at the top of every code module? I ask because you have a lot of undeclared variables.

If not, add it.

If you use indentation in your code it makes it easier to see where you are.

Try it like this:

  Dim JSON As Object
  Dim itm As Object
  Dim lineItm As Object
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim rst As DAO.Recordset
  Set db = CurrentDb
  Set rs = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)
  Set rst = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)

  Set JSON = ParseJson(Request.ResponseText)
  'i = 1
  For Each itm In JSON("data")("saleList")
  'Process data.
  'Purchases header details to saved in the parent table
    rs.AddNew
      rs("OurTPIN") = itm("spplrTpin")
      rs("bhfId") = itm("spplrBhfId")
      rs("spplrInvcNo") = itm("spplrInvcNo")
      rs("rcptTyCd") = itm("rcptTyCd")
      rs("pmtTyCd") = itm("pmtTyCd")
      rs("cfmDt") = itm("cfmDt")
      rs("pchsDt") = CDate(Format$((itm("salesDt")), "00/00/00"))
      rs("wrhsDt") = itm("stockRlsDt")
      rs("totItemCnt") = itm("totItemCnt")
      rs("taxblAmtA") = itm("taxblAmtA")
      rs("taxblAmtB") = itm("taxblAmtB")
      rs("taxRtA") = itm("taxRtA")
      rs("taxRtB") = itm("taxRtB")
      rs("taxRtD") = itm("taxRtD")
      rs("taxRtB") = itm("taxRtB")
      rs("taxAmtA") = itm("taxAmtA")
      rs("taxAmtB") = itm("taxAmtB")
      rs("taxAmtC1") = itm("taxAmtC1")
      rs("taxAmtC2") = itm("taxAmtC2")
      rs("taxAmtD") = itm("taxAmtD")
      rs("totTaxblAmt") = itm("totTaxblAmt")
      rs("totTaxAmt") = itm("totTaxAmt")
      rs("totAmt") = itm("totAmt")
      rs("remark") = itm("remark")
      rs("regrNm") = "Admin"
      rs("regrId") = "Admin"
      rs("modrNm") = "Admin"
      rs("modrId") = "Admin"
    rs.Update
    'Purchases details to saved in the child table
    ' z = 1   ' <-- What is this for? It is not even declared
    For Each lineItm In itm("itemList")
      rst.AddNew
        rst("itemSeq") = lineItm("itemSeq")
        rst("itemCd") = lineItm("itemCd")
        rst("itemClsCd") = lineItm("itemClsCd")
        rst("itemNm") = lineItm("itemNm")
        rst("bcd") = lineItm("bcd")
        rst("pkg") = lineItm("pkg")
        rst("qtyUnitCd") = lineItm("qtyUnitCd")
        rst("qty") = lineItm("qty")
        rst("prc") = lineItm("prc")
        rst("splyAmt") = lineItm("splyAmt")
        rst("dcRt") = lineItm("dcRt")
        rst("dcAmt") = lineItm("dcAmt")
        rst("taxblAmt") = lineItm("taxblAmt")
        rst("taxAmt") = lineItm("vatAmt")
        rst("totAmt") = lineItm("totAmt")
        rst("PurchID") = rs("PurchID")
      rst.Update
    Next
  Next
    
  MsgBox "Please note that data import is now done", vbCritical, "Done!"
  rs.Close
  rst.Close
  Set rs = Nothing
  Set rst = Nothing
  Set db = Nothing
  Set JSON = Nothing
  Set itm = Nothing
  Set lineItm = Nothing

 

[nector]

Kindly note sir , the top part purchases header is working okay no problem , the challenge is on the second part or the purchases details or child table. Below is my full code :

Private Sub CmdlocalPurchasesSearch_Click()
Dim n As Integer
Dim z As Integer
Dim JSON As Object
Dim item As Object
Dim accounts As Object
Dim Request As Object
Dim strData As String
Dim stUrl As String
Dim Response As String
Dim requestBody As String
Dim Company As New Dictionary
Set Company = New Dictionary

stUrl = "http://192.168.1.23:8080/zrasandboxvsdc/trnsPurchase/selectTrnsPurchaseSales"
Set Request = CreateObject("MSXML2.XMLHTTP")
Company.Add "tpin", "1002623668"
Company.Add "bhfId", "000"
Company.Add "lastReqDt", Format((Me.txtlastdateLocalPurchases), "YYYYMMDD000000")
strData = JsonConverter.ConvertToJson(Company, Whitespace:=3)
requestBody = strData
    With Request
        .Open "POST", stUrl, False
        .setRequestHeader "Content-type", "application/json"
        .send requestBody
        Response = .ResponseText
    End With
If Request.Status = 200 Then
MsgBox Request.ResponseText, vbCritical, "Internal Audit Manager"
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim PK As Long
Set db = CurrentDb
Set rs = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)
Set rst = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)


Set JSON = ParseJson(Request.ResponseText)

'i = 1
For Each item In JSON("data")("saleList")
  
'Process data.

'Purchases header details to saved in the parent table
rs.AddNew
rs("OurTPIN") = item("spplrTpin")
rs("bhfId") = item("spplrBhfId")
rs("spplrInvcNo") = item("spplrInvcNo")
rs("rcptTyCd") = item("rcptTyCd")
rs("pmtTyCd") = item("pmtTyCd")
rs("cfmDt") = item("cfmDt")
rs("pchsDt") = CDate(Format$((item("salesDt")), "00/00/00"))
rs("wrhsDt") = item("stockRlsDt")
rs("totItemCnt") = item("totItemCnt")
rs("taxblAmtA") = item("taxblAmtA")
rs("taxblAmtB") = item("taxblAmtB")
rs("taxRtA") = item("taxRtA")
rs("taxRtB") = item("taxRtB")
rs("taxRtD") = item("taxRtD")
rs("taxRtB") = item("taxRtB")
rs("taxAmtA") = item("taxAmtA")
rs("taxAmtB") = item("taxAmtB")
rs("taxAmtC1") = item("taxAmtC1")
rs("taxAmtC2") = item("taxAmtC2")
rs("taxAmtD") = item("taxAmtD")
rs("totTaxblAmt") = item("totTaxblAmt")
rs("totTaxAmt") = item("totTaxAmt")
rs("totAmt") = item("totAmt")
rs("remark") = item("remark")
rs("regrNm") = "Admin"
rs("regrId") = "Admin"
rs("modrNm") = "Admin"
rs("modrId") = "Admin"
rs.Update
rst.Edit
rst("PurchID") = rs("PurchID")
rst.Update
Next
'Purchases details to saved in the child table

z = 1

For Each item In JSON("data")("saleList")
rst.AddNew
rst("itemSeq") = item("itemSeq")
rst("itemCd") = item("itemCd")
rst("itemClsCd") = item("itemClsCd")
rst("itemNm") = item("itemNm")
rst("bcd") = item("bcd")
rst("pkg") = item("pkg")
rst("qtyUnitCd") = item("qtyUnitCd")
rst("qty") = item("qty")
rst("prc") = item("prc")
rst("splyAmt") = item("splyAmt")
rst("dcRt") = item("dcRt")
rst("dcAmt") = item("dcAmt")
rst("taxblAmt") = item("taxblAmt")
rst("taxAmt") = item("vatAmt")
rst("totAmt") = item("totAmt")
rst("PurchID") = rs("PurchID")
rst.Update

Next
    
MsgBox "Please note that data import is now done", vbCritical, "Done!"
rs.Close
rst.Close
Set rs = Nothing
Set rst = Nothing
Set db = Nothing
Set JSON = Nothing
Set item = Nothing
Exit Sub
End If
End Sub

 

[cheekybuddha]

Did you compare the changes I suggested?

 

[cheekybuddha]

item is a reserved word - better not to use it as a variable name

 

[nector]

Many thanks martin , now I'm receiving all the data except the foreign key issue , once again many thanks sir.

regards

Chris

 

[nector]

If the foreign key can be insert logically then that will be very fine but all the same.

 

[cheekybuddha]

So, what do your results look like - remember we can not see your screen.

Describe in detail 'the foreign key issue'

 

[nector]

Many thanks David , with your concept it led be to use Dlast function , finally its now able to link all the invoices correctly, I must say without your contribution I was completely lost here

Many thanks sir.

Regards

Chris

 

[cheekybuddha]

You're welcome. I'm pleased you have it working, though I'm surprised you need to use DLast().

However, if it works ...

Perhaps post your final solution here so everyone can learn from your success.

 

[nector]

Well below is my final working code

Private Sub CmdlocalPurchasesSearch_Click()
Dim n As Integer
Dim z As Integer
Dim JSON As Object
Dim item As Object
Dim lineItm As Object
Dim itm As Object
Dim Request As Object
Dim strData As String
Dim stUrl As String
Dim Response As String
Dim requestBody As String
Dim Company As New Dictionary
Set Company = New Dictionary

stUrl = "http://hostname:8080/nector/trnsPurchases/selectTrnsPurchase"
Set Request = CreateObject("MSXML2.XMLHTTP")
Company.Add "tpin", "1002623668"
Company.Add "bhfId", "000"
Company.Add "lastReqDt", Format((Me.txtlastdateLocalPurchases), "YYYYMMDD000000")
strData = JsonConverter.ConvertToJson(Company, Whitespace:=3)
requestBody = strData
    With Request
        .Open "POST", stUrl, False
        .setRequestHeader "Content-type", "application/json"
        .send requestBody
        Response = .ResponseText
    End With
If Request.Status = 200 Then

MsgBox Request.ResponseText, vbCritical, "Internal Audit Manager"

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim PK As Long
Set db = CurrentDb
Set rs = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)
  Set rst = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)

  Set JSON = ParseJson(Request.ResponseText)
  'i = 1
  For Each itm In JSON("data")("saleList")
  'Process data.
  'Purchases header details to saved in the parent table
    rs.AddNew
      rs("OurTPIN") = itm("spplrTpin")
      rs("bhfId") = itm("spplrBhfId")
      rs("spplrInvcNo") = itm("spplrInvcNo")
      rs("rcptTyCd") = itm("rcptTyCd")
      rs("pmtTyCd") = itm("pmtTyCd")
      rs("cfmDt") = itm("cfmDt")
      rs("pchsDt") = CDate(Format$((itm("salesDt")), "00/00/00"))
      rs("wrhsDt") = itm("stockRlsDt")
      rs("totItemCnt") = itm("totItemCnt")
      rs("taxblAmtA") = itm("taxblAmtA")
      rs("taxblAmtB") = itm("taxblAmtB")
      rs("taxRtA") = itm("taxRtA")
      rs("taxRtB") = itm("taxRtB")
      rs("taxRtD") = itm("taxRtD")
      rs("taxRtB") = itm("taxRtB")
      rs("taxAmtA") = itm("taxAmtA")
      rs("taxAmtB") = itm("taxAmtB")
      rs("taxAmtC1") = itm("taxAmtC1")
      rs("taxAmtC2") = itm("taxAmtC2")
      rs("taxAmtD") = itm("taxAmtD")
      rs("totTaxblAmt") = itm("totTaxblAmt")
      rs("totTaxAmt") = itm("totTaxAmt")
      rs("totAmt") = itm("totAmt")
      rs("remark") = itm("remark")
      rs("regrNm") = "Admin"
      rs("regrId") = "Admin"
      rs("modrNm") = "Admin"
      rs("modrId") = "Admin"
      rs.Update
 
'Purchases details to saved in the child table
    ' z = 1   ' <-- What is this for? It is not even declared
    For Each lineItm In itm("itemList")
      rst.AddNew
        rst("itemSeq") = lineItm("itemSeq")
        rst("itemCd") = lineItm("itemCd")
        rst("itemClsCd") = lineItm("itemClsCd")
        rst("itemNm") = lineItm("itemNm")
        rst("bcd") = lineItm("bcd")
        rst("pkg") = lineItm("pkg")
        rst("qtyUnitCd") = lineItm("qtyUnitCd")
        rst("qty") = lineItm("qty")
        rst("prc") = lineItm("prc")
        rst("splyAmt") = lineItm("splyAmt")
        rst("dcRt") = lineItm("dcRt")
        rst("dcAmt") = lineItm("dcAmt")
        rst("taxblAmt") = lineItm("taxblAmt")
        rst("taxAmt") = lineItm("vatAmt")
        rst("totAmt") = lineItm("totAmt")
        rst("vatCatCd") = lineItm("vatCatCd")
        rst("PurchID") = DLast("PurchID", "tblpurchases")
      rst.Update
    Next
  Next
MsgBox "Please note that data import is now done", vbCritical, "Done!"
rs.Close
rst.Close
Set rs = Nothing
Set rst = Nothing
Set db = Nothing
Set JSON = Nothing
Set item = Nothing
Exit Sub
End If
End Sub

 

[Josef P.]

A small refactoring:

Private Sub CmdlocalPurchasesSearch_Click()
   InsertLocalPurchases Me.txtlastdateLocalPurchases.Value
End Sub

Private Sub InsertLocalPurchases(ByVal LastDateLocalPurchases As Date)

    Dim ResponseText As String
    Dim RequestBody As String
    Dim Company As Dictionary   '<-- is this really a 'Company'?
    
    Set Company = NewCompanyDictionary() ' get default dictionary with PIN and bhfId ... reusable
    Company.Add "lastReqDt", Format(LastDateLocalPurchases, "YYYYMMDD000000")

    RequestBody = JsonConverter.ConvertToJson(Company, Whitespace:=3)
    ResponseText = GetPurchasesJsonFromWebService(RequestBody)
    If Len(ResponseText) = 0 Then
       MsgBox "Empty ResponseText"
       Exit Sub
    End If
    
    MsgBox ResponseText, vbCritical, "Internal Audit Manager"
    
    InsertLocalPurchasesFromJson ResponseText

End Sub

Private Sub InsertLocalPurchasesFromJson(ByVal JsonString As String)

    Dim Json As Object
    Dim db As DAO.Database
    Dim rsHeader As DAO.Recordset
    Dim rsDetail As DAO.Recordset
    Dim itm As Object
    Dim NewPurchID As Long

    Json = JsonConverter.ParseJson(JsonString)
  
    Set db = CurrentDb
    Set rsHeader = db.OpenRecordset("tblpurchases", dbOpenDynaset, dbSeeChanges)   '<-- full recordset is required?
    Set rsDetail = db.OpenRecordset("tblPurchasesDetails", dbOpenDynaset, dbSeeChanges)
    
    For Each itm In Json("data")("saleList")
        NewPurchID = AddPurchaseHeader(rsHeader, itm) ' Function returns new value from PurchID
        AddPurchaseItems rsDetail, itm("itemList"), NewPurchID
    Next
  
    MsgBox "Please note that data import is now done", vbCritical, "Done!"
    
    rsDetail.Close
    Set rsDetail = Nothing
    rsHeader.Close
    Set rsHeader = Nothing
    
    Set db = Nothing

End Sub

Private Function AddPurchaseHeader(ByVal rs As DAO.Recordset, ByVal PurchaseJson As Object) As Long

    Dim NewPk As Long

    rs.AddNew
    rs("OurTPIN") = PurchaseJson("spplrTpin")
    rs("bhfId") = PurchaseJson("spplrBhfId")
    rs("spplrInvcNo") = PurchaseJson("spplrInvcNo")
    rs("rcptTyCd") = PurchaseJson("rcptTyCd")
    rs("pmtTyCd") = PurchaseJson("pmtTyCd")
    rs("cfmDt") = PurchaseJson("cfmDt")
    rs("pchsDt") = CDate(Format$((PurchaseJson("salesDt")), "00/00/00"))
    rs("wrhsDt") = PurchaseJson("stockRlsDt")
    rs("totItemCnt") = PurchaseJson("totItemCnt")
    rs("taxblAmtA") = PurchaseJson("taxblAmtA")
    rs("taxblAmtB") = PurchaseJson("taxblAmtB")
    rs("taxRtA") = PurchaseJson("taxRtA")
    rs("taxRtB") = PurchaseJson("taxRtB")
    rs("taxRtD") = PurchaseJson("taxRtD")
    rs("taxRtB") = PurchaseJson("taxRtB")
    rs("taxAmtA") = PurchaseJson("taxAmtA")
    rs("taxAmtB") = PurchaseJson("taxAmtB")
    rs("taxAmtC1") = PurchaseJson("taxAmtC1")
    rs("taxAmtC2") = PurchaseJson("taxAmtC2")
    rs("taxAmtD") = PurchaseJson("taxAmtD")
    rs("totTaxblAmt") = PurchaseJson("totTaxblAmt")
    rs("totTaxAmt") = PurchaseJson("totTaxAmt")
    rs("totAmt") = PurchaseJson("totAmt")
    rs("remark") = PurchaseJson("remark")
    rs("regrNm") = "Admin"
    rs("regrId") = "Admin"
    rs("modrNm") = "Admin"
    rs("modrId") = "Admin"
    rs.Update
    
    rs.Bookmark = rs.LastModified
    NewPk = rs.Fields("PurchID").Value
    
    AddPurchaseHeader = NewPk

End Function

Private Function AddPurchaseItems(ByVal rst As DAO.Recordset, ByVal PurchaseJsonItems As Object, ByVal PurchID As Long) As Long

    Dim LineItm As Object

    For Each LineItm In PurchaseJsonItems
        rst.AddNew
        rst("itemSeq") = LineItm("itemSeq")
        rst("itemCd") = LineItm("itemCd")
        rst("itemClsCd") = LineItm("itemClsCd")
        rst("itemNm") = LineItm("itemNm")
        rst("bcd") = LineItm("bcd")
        rst("pkg") = LineItm("pkg")
        rst("qtyUnitCd") = LineItm("qtyUnitCd")
        rst("qty") = LineItm("qty")
        rst("prc") = LineItm("prc")
        rst("splyAmt") = LineItm("splyAmt")
        rst("dcRt") = LineItm("dcRt")
        rst("dcAmt") = LineItm("dcAmt")
        rst("taxblAmt") = LineItm("taxblAmt")
        rst("taxAmt") = LineItm("vatAmt")
        rst("totAmt") = LineItm("totAmt")
        rst("vatCatCd") = LineItm("vatCatCd")
        rst("PurchID") = PurchID ' was DLast("PurchID", "tblpurchases")
        rst.Update
    Next

End Function

Private Function NewCompanyDictionary() As Dictionary

    Dim CompDict As Dictionary
    
    Set CompDict = New Dictionary
    
    CompDict.Add "tpin", "1002623668"
    CompDict.Add "bhfId", "000"
    
    Set NewCompanyDictionary = CompDict
    
End Function

Private Function GetPurchasesJsonFromWebService(ByVal RequestBody As String) As String

    Const stUrl As String = "http://hostname:8080/nector/trnsPurchases/selectTrnsPurchase"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", stUrl, False
        .setRequestHeader "Content-type", "application/json"
        .send RequestBody
        If .Status = 200 Then
            GetPurchasesJsonFromWebService = .ResponseText
        End If
    End With
  
End Function

There are still a few places in the code that would not mind being optimised.

 

[nector]

Many thanks

Josef P.​

The original code works very well and it takes only 1.5 seconds to insert 20 invoices from the internet so I would not want to change anything now.