Solved Caching recordset in MS Access VBA (1 Viewer)

N

nector

Member
Local time
Today, 02:53
Joined
Jan 21, 2020
Messages
462
Hi all,

I'm trying to speed up the record set in MS Access being used by the VBA code below, see the code, but I got mixed up in the middle especially on the issue below by the way this is based on linked table to AZURE:

(1) What happens with the concurrent users, suppose someone post a record while caching what happens
(2) How to properly start the caching and ending the caching

Any idea on the code below can be amended:

Code: 
Public Sub CmdCwrite_Click()
Call CmdCmdTotalClasses_Click
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim Company As New Dictionary
Dim strData As String
Dim Json As Object
Dim data As New Dictionary
Dim transactions As Collection
Dim itemCount As Long
Dim i As Long
Dim n As Integer
Dim z As Integer
Dim item As New Dictionary
Dim items As New Collection
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Set db = CurrentDb
Set qdf = db.QueryDefs("QryJsonPos001")



For Each prm In qdf.Parameters
     prm = Eval(prm.Name)
Next prm

Set rs = qdf.OpenRecordset(dbOpenSnapshot, dbSeeChanges)
'Caching recordset
With rs
.CacheStart = .Bookmark
.CacheSize = 100
.FillCache
End With

    Set qdf = Nothing
    rs.MoveFirst
    Do While Not rs.EOF
Set data = New Dictionary
Set transactions = New Collection
Set Company = New Dictionary
        Company.Add "tpin", rs!suptpin.Value
        Company.Add "bhfId", rs!bhfId.Value
        Company.Add "invcNo", rs!ItemSoldID.Value
        Company.Add "orgInvcNo", Nz(rs!OrignalInvoiceNumber.Value, 0)
        Company.Add "custTpin", rs!TPIN.Value
        Company.Add "prcOrdCd", IIf((rs!NewprcOrdCd.Value = "0"), 0, "")
        Company.Add "custNm", rs!Company.Value
        Company.Add "salesTyCd", "N"
        Company.Add "rcptTyCd", rs!DocCodes.Value
        Company.Add "pmtTyCd", IIf((rs!DocCodes.Value = "S"), "04", "07")
        Company.Add "salesSttsCd", "02"
        Company.Add "cfmDt", rs!ActualDate.Value
        Company.Add "salesDt", Format((rs!PosDate), "yyyymmdd")
        Company.Add "stockRlsDt", IIf(Len(rs!stockreleasing), rs!stockreleasing, Null)
        Company.Add "cnclReqDt", Null
        Company.Add "cnclDt", Null
        Company.Add "rfdDt", Null
        Company.Add "rfdRsnCd", rs!rfdRsnCding.Value
        Company.Add "totItemCnt", Me.txtinternalaudit
        Company.Add "taxblAmtA", Round(Nz(Me.txtclassA, 0), 2)
        Company.Add "taxblAmtB", Round(Nz(Me.txtclassB, 0), 2)
        Company.Add "taxblAmtC1", Round(Nz(Me.txtclassC1, 0), 2)
        Company.Add "taxblAmtC2", Round(Nz(Me.txtclassC2, 0), 2)
        Company.Add "taxblAmtC3", Round(Nz(Me.txtclassC3, 0), 2)
        Company.Add "taxblAmtD", Round(Nz(Me.txtclassD, 0), 2)
        Company.Add "taxblAmtRvat", 0
        Company.Add "taxblAmtE", 0
        Company.Add "taxblAmtF", 0
        Company.Add "taxblAmtIpl1", 0
        Company.Add "taxblAmtIpl2", 0
        Company.Add "taxblAmtTl", 0
        Company.Add "taxblAmtEcm", 0
        Company.Add "taxblAmtExeeg", 0
        Company.Add "taxblAmtTot", 0
        Company.Add "taxRtA", 16
        Company.Add "taxRtB", 16
        Company.Add "taxRtC1", 0
        Company.Add "taxRtC2", 0
        Company.Add "taxRtC3", 0
        Company.Add "taxRtD", 0
        Company.Add "taxRtE", 0
        Company.Add "taxRtF", 0
        Company.Add "taxRtIpl1", 0
        Company.Add "taxRtIpl2", 0
        Company.Add "taxRtTl", 0
        Company.Add "taxRtEcm", 0
        Company.Add "taxRtExeeg", 0
        Company.Add "taxRtTot", 0
        Company.Add "taxRtRvat", 0
        Company.Add "taxAmtA", Round(Nz(Me.txtttaxclassA, 0), 2)
        Company.Add "taxAmtB", Round(Nz(Me.txtttaxclassb, 0), 2)
        Company.Add "taxAmtC1", 0
        Company.Add "taxAmtC2", 0
        Company.Add "taxAmtC3", 0
        Company.Add "taxAmtD", 0
        Company.Add "taxAmtE", 0
        Company.Add "taxAmtF", 0
        Company.Add "taxAmtIpl1", 0
        Company.Add "taxAmtIpl2", 0
        Company.Add "taxAmtTl", 0
        Company.Add "taxAmtEcm", 0
        Company.Add "taxAmtExeeg", 0
        Company.Add "taxAmtTot", 0
        Company.Add "taxAmtRvat", 0
        Company.Add "totTaxblAmt", Round(Nz(Me.txttotaxableAB, 0), 2)
        Company.Add "totTaxAmt", Round(Nz(Me.txttotaltaxAll, 0), 2)
        Company.Add "totAmt", Round(Nz(Me.txtGrandtotal, 0), 2)
        Company.Add "prchrAcptcYn", rs!prchrAcptcYn.Value
        Company.Add "remark", rs!TheNotes.Value
        Company.Add "regrId", "11999"
        Company.Add "regrNm", rs!Cashier.Value
        Company.Add "modrId", "45678"
        Company.Add "modrNm", rs!Cashier.Value
        Company.Add "receipt", data
        data.Add "custTpin", rs!TPIN.Value
        data.Add "custMblNo", rs!Phone.Value
        data.Add "rptNo", 0
        data.Add "trdeNm", rs!Company.Value
        data.Add "adrs", rs!Address.Value
        data.Add "topMsg", ""
        data.Add "btmMsg", "Thank you for choosing us"
        data.Add "prchrAcptcYn", rs!prchrAcptcYn.Value
        Company.Add "itemList", transactions
            
    '--- loop over all the items
        itemCount = Me.txtinternalaudit
      
        For i = 1 To itemCount
            Set item = New Dictionary
            transactions.Add item
            item.Add "itemSeq", i
            item.Add "itemCd", rs!itemCd.Value
            item.Add "itemClsCd", rs!itemClsCd.Value
            item.Add "itemNm", rs!ProductName.Value
            item.Add "bcd", Null
            item.Add "pkgUnitCd", "NT"
            item.Add "pkg", 1
            item.Add "qtyUnitCd", "U"
            item.Add "qty", rs!Qty.Value
            item.Add "prc", rs!SellingPrice.Value
            item.Add "splyAmt", rs!SellingPrice.Value
            item.Add "dcRt", 0
            item.Add "dcAmt", 0
            item.Add "isrccCd", Null
            item.Add "isrccNm", Null
            item.Add "isrcRt", Null
            item.Add "isrcAmt", Null
            item.Add "vatCatCd", rs!TaxClassA.Value
            item.Add "iplCatCd", "IPL1"
            item.Add "tlCatCd", "TL"
            item.Add "exciseCatCd", "EXEEG"
            item.Add "taxblAmt", Round(rs!SupplierAmount.Value, 2)
            item.Add "vatAmt", Round(rs!FinalTax.Value, 2)
            item.Add "iplAmt", Null
            item.Add "tlAmt", Null
            item.Add "exciseAmt", Null
            item.Add "totAmt", Round(rs!TotalAmount.Value, 2)

strData = JsonConverter.ConvertToJson(Company, Whitespace:=3)
rs.MoveNext
Next
Loop
Dim Request As Object
Dim stUrl As String
Dim Response As String
Dim requestBody As String
Dim Details As Variant
stUrl = "http://XXXXXXXXXXXXXXX"
Set Request = CreateObject("MSXML2.XMLHTTP")
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("select vsdcRcptPbctDate,rcptNo,intrlData,rcptSign,sdcId FROM [tblPOSStocksSold] WHERE [ItemSoldID] = " & Me.txtJsonReceived, dbOpenDynaset)
Set Json = JsonConverter.ParseJson(Request.responsetext)
'Process data.
On Error Resume Next
rst.Edit
rst![rcptNo] = Json("data")("rcptNo")
rst![intrlData] = Json("data")("intrlData")
rst![rcptSign] = Json("data")("rcptSign")
rst![vsdcRcptPbctDate] = Json("data")("vsdcRcptPbctDate")
rst![sdcId] = Json("data")("sdcId")
rst.Update
On Error Resume Next
ElseIf (Request.Status <> 200) Then
MsgBox Request.responsetext, vbCritical, "Internal Audit Manager"

rs.Close
rst.Close
Set rst = Nothing
Set rs = Nothing
Set qdf = Nothing
Set prm = Nothing
Set Json = Nothing
End If
End Sub
 
I note that you have yet to receive a reply hence I am bumping your question up the list so that it gets another run through the mill!
 
That is a lot of moving parts...
 
Thank you so much uncle GIZMO. We have done and followed the rules of SQL Server, example:

(1) All the forms open empty including its combo boxes, the combo boxes only start building a short list when the user type in the combo box 3 matching characters
(2) All queries are handled by the server (Transferred to the server), actually MS Access has nothing to calculate

Major problem

Record Source query below (QryJsonPos001)

Code: 
SELECT
SELECT tblProducts.ProductName, tblProducts.ProductID, (IIf(([TaxClassA]<>"B"),((([Qty]*[SellingPrice]))),0)+IIf(([TaxClassA]="B"),((([Qty]*[RRP]))),0)) AS TotalAmount, IIf([IsTaxInclusive]<0,"True","False") AS CGControl, ((IIf(([SellingPrice]>[RRP]),(((([SellingPrice])*[Tax]*1))/1.16),(((([RRP])*[Tax]*1))/1.16)))*[QtySold]) AS FinalTax, (IIf(([TaxClassA]="TV"),((([SellingPrice])/(1+[TurnoverTax]))*[QtySold]),(IIf(([RRP]>[SellingPrice]),(((([RRP])/(1+(Nz([Tax],0)+Nz([TourismLevy],0))))*[QtySold])),(((([SellingPrice])/(1+(Nz([Tax],0)+Nz([TourismLevy],0))))*[QtySold])))))) AS TaxableValue, IIf(([FinalTax] Is Not Null),[TaxableValue],Null) AS TaxableAB, Round((Nz([FinalTax],0)+Nz([TaxableValue],0)),2) AS TaxInclusive, (IIf(([TaxClassA]<>"B"),((([QtySold]*[SellingPrice]))),0)+IIf(([TaxClassA]="B"),((([QtySold]*[RRP]))),0)) AS SupplierAmount, (((IIf(([TaxClassA]="TV"),((([SellingPrice])/(1+[TurnoverTax]))*[QtySold]),(IIf(([RRP]>[SellingPrice]),(((([RRP])/(1+(Nz([Tax],0)+Nz([TourismLevy],0))))*[QtySold])),(((([SellingPrice])/(1+(Nz([Tax],0)+Nz([TourismLevy],0))))*[QtySold])))))))*0) AS DiscountValue, tblProducts.itemClsCd, tblProducts.itemCd, tblProducts.Barcode, tblPOSStocksSold.ItemSoldID, tblCustomers.Company, tblPosLineDetails.TaxClassA, tblCustomers.TPIN, tblPOSStocksSold.TheNotes, tblPOSStocksSold.Cashier, tblCustomers.Address, tblPosLineDetails.QtySold, tblPosLineDetails.SellingPrice, tblPOSStocksSold.OrignalInvoiceNumber, tblPOSStocksSold.OrignalInvoiceCode, (((([RRP])*[Tax]*1))/1.16) AS RRPrice, tblPosLineDetails.Tax, Nz(0,0) AS prcOrdCd, "" AS prcOrdCdss, IIf(([DocCodes]="S"),Nz([prcOrdCd],0),[prcOrdCdss]) AS NewprcOrdCd, tblDocuments.DocCodes, Format(((IIf(([DocCodes]="S"),Now(),Null))),"yyyymmddhhnnss") AS stockreleasing, Format((Now()),"yyyymmddhhnnss") AS ActualDate, IIf(([DocCodes]="S"),"N","Y") AS prchrAcptcYn, IIf(([DocCodes]="S"),Null,"05") AS rfdRsnCding, tblDocuments.DocType, tblPOSStocksSold.PosDate, tblCustomers.Phone, tblPOSStocksSold.bhfId, tblPOSStocksSold.suptpin, tblDocuments.DocID, (IIf(([DocCodes]="R"),([QtySold]*-1),[QtySold])) AS Qty
FROM tblCustomers INNER JOIN ((tblPOSStocksSold INNER JOIN tblDocuments ON tblPOSStocksSold.DocID = tblDocuments.DocID) INNER JOIN (tblProducts INNER JOIN tblPosLineDetails ON tblProducts.ProductID = tblPosLineDetails.ProductID) ON tblPOSStocksSold.ItemSoldID = tblPosLineDetails.ItemSoldID) ON tblCustomers.CustomerID = tblPOSStocksSold.CustomerID
WHERE (((tblPOSStocksSold.ItemSoldID)=[Forms]![frmPOSStocksSold]![CboEsdss]));

The above query if I take it to the server after removing all items not recognised by the server, it will open almost instant in MS Access FE but when you use it in the above VBA and run the loop in Json fields above it will take five minutes to complete and send the data to the virtual server.

But if I leave it in MS Access the way it is it will finish sending data in 2 minutes a gain of 3 minutes but still user want to have the data sent instantly, that is where the issue is. The users are running a supermarket and so they do not want to see large ques

(1) Changing the objects from DAO to ADO will be a non-starter because it will mean rewriting all the codes again and retesting.
(2) Creating two temporal tables and then transferring the data every after one invoice has the following challenges

- How to create a code to insert data into linked parent and child tables, this one is very challenging even if it was possible but remember MS Access insert data into the server over the wire line by line which will lengthen the process making everything worse off in term of delays
- This a multiuser software where invoice number must follow each other.
 
Last edited:
[OT]

Making the select statement with the joins available as an SQL server view (in FE as linked table) or using a pass-through query is not an option?
 
Making the select statement with the joins available as an SQL server view or using a pass-through query is not an option?

I used a view directly in the server, this works well but the problem comes in at VBA stage it looks like VBA does not like opening the record set from a view or PT

What is surprising me is that when you double click a linked view in MS Access it opens almost instantly , but the same view to make the data available for the recordset to loop in through it takes 5 minutes which is too much.
 
I used a view directly in the server, this works well but the problem comes in at VBA stage it looks like VBA does not like opening the record set from a view or PT
Click to expand...
That should already work. Is there an error message for this?

Have you already tried this variant?
Code: 
SELECT ProductName, ProductID, TotalAmount, CGControl, TaxableValue, ITaxableAB, TaxInclusive, DiscountValue, itemClsCd, itemCd, Barcode, ItemSoldID, Company, TaxClassA, TPIN, TheNotes, Cashier, Address, QtySold, SellingPrice, OrignalInvoiceNumber, OrignalInvoiceCode, RRPrice, Tax, prcOrdCd, prcOrdCdss, NewprcOrdCd, DocCodes, stockreleasing, ActualDate, prchrAcptcYn, rfdRsnCding, DocType, PosDate, Phone, bhfId, suptpin, DocID, Qty
FROM YourLinkedSqlServerView
WHERE ItemSoldID=[Forms]![frmPOSStocksSold]![CboEsdss]
 
That should already work. Is there an error message for this?

Have you already tried this variant?


Yes I did there are no errors at all the code works whether placed in SQL Server as a view or select query in MS Access, the problem is that its takes 5 minutes to provide the much needed data.

But the same code if ran in MS Access database it take 0.09 seconds almost instantly
 
But the same code if ran in MS Access database it take 0.09 seconds almost instantly
Click to expand...
Only opening the query or measured incl. moving to the end of the data records?
 
The statement that rings a bell is "run the loop". WHAT loop? The query should bring down ALL the records you need to export, not one at a time. Access reads each row and builds the json string.
 
The statement that rings a bell is "run the loop". WHAT loop? The query should bring down ALL the records you need to export, not one at a time. Access reads each row and builds the json string.


Below is the result of the loop and that is what is taking too long to process! If I was to add 100 lines then it will take now hours


Code: 
{
   "tpin": "XXXXXXXXXX",
   "bhfId": "000",
   "invcNo": 6813,
   "orgInvcNo": 0,
   "custTpin": "1002623668",
   "prcOrdCd": 0,
   "custNm": "SAMPLE CASH SALES",
   "salesTyCd": "N",
   "rcptTyCd": "S",
   "pmtTyCd": "04",
   "salesSttsCd": "02",
   "cfmDt": "20240511082648",
   "salesDt": "20240511",
   "stockRlsDt": "20240511082648",
   "cnclReqDt": null,
   "cnclDt": null,
   "rfdDt": null,
   "rfdRsnCd": null,
   "totItemCnt": 2,
   "taxblAmtA": 118.8,
   "taxblAmtB": 180,
   "taxblAmtC1": 0,
   "taxblAmtC2": 0,
   "taxblAmtC3": 0,
   "taxblAmtD": 0,
   "taxblAmtRvat": 0,
   "taxblAmtE": 0,
   "taxblAmtF": 0,
   "taxblAmtIpl1": 0,
   "taxblAmtIpl2": 0,
   "taxblAmtTl": 0,
   "taxblAmtEcm": 0,
   "taxblAmtExeeg": 0,
   "taxblAmtTot": 0,
   "taxRtA": 16,
   "taxRtB": 16,
   "taxRtC1": 0,
   "taxRtC2": 0,
   "taxRtC3": 0,
   "taxRtD": 0,
   "taxRtE": 0,
   "taxRtF": 0,
   "taxRtIpl1": 0,
   "taxRtIpl2": 0,
   "taxRtTl": 0,
   "taxRtEcm": 0,
   "taxRtExeeg": 0,
   "taxRtTot": 0,
   "taxRtRvat": 0,
   "taxAmtA": 16.39,
   "taxAmtB": 24.83,
   "taxAmtC1": 0,
   "taxAmtC2": 0,
   "taxAmtC3": 0,
   "taxAmtD": 0,
   "taxAmtE": 0,
   "taxAmtF": 0,
   "taxAmtIpl1": 0,
   "taxAmtIpl2": 0,
   "taxAmtTl": 0,
   "taxAmtEcm": 0,
   "taxAmtExeeg": 0,
   "taxAmtTot": 0,
   "taxAmtRvat": 0,
   "totTaxblAmt": 298.8,
   "totTaxAmt": 41.21,
   "totAmt": 298.8,
   "prchrAcptcYn": "N",
   "remark": null,
   "regrId": "11999",
   "regrNm": "Admin Manager",
   "modrId": "45678",
   "modrNm": "Admin Manager",
   "receipt": {
      "custTpin": "XXXXXXXXXXX",
      "custMblNo": "XXXXXXXXXX",
      "rptNo": 0,
      "trdeNm": "SAMPLE CASH SALES",
      "adrs": "BOX 356200 ,XXXXXXX",
      "topMsg": "",
      "btmMsg": "Thank you for choosing us",
      "prchrAcptcYn": "N"
   },
   "itemList": [
      {
         "itemSeq": 1,
         "itemCd": "ZM2NTU00000013",
         "itemClsCd": "40000013",
         "itemNm": "PACKAGED WATER 1000 ML",
         "bcd": null,
         "pkgUnitCd": "NT",
         "pkg": 1,
         "qtyUnitCd": "U",
         "qty": 1,
         "prc": 118.8,
         "splyAmt": 118.8,
         "dcRt": 0,
         "dcAmt": 0,
         "isrccCd": null,
         "isrccNm": null,
         "isrcRt": null,
         "isrcAmt": null,
         "vatCatCd": "A",
         "iplCatCd": "IPL1",
         "tlCatCd": "TL",
         "exciseCatCd": "EXEEG",
         "taxblAmt": 118.8,
         "vatAmt": 16.39,
         "iplAmt": null,
         "tlAmt": null,
         "exciseAmt": null,
         "totAmt": 118.8
      },
      {
         "itemSeq": 2,
         "itemCd": "ZM2NTU00000014",
         "itemClsCd": "40000014",
         "itemNm": "CEMENT",
         "bcd": null,
         "pkgUnitCd": "NT",
         "pkg": 1,
         "qtyUnitCd": "U",
         "qty": 1,
         "prc": 148.5,
         "splyAmt": 148.5,
         "dcRt": 0,
         "dcAmt": 0,
         "isrccCd": null,
         "isrccNm": null,
         "isrcRt": null,
         "isrcAmt": null,
         "vatCatCd": "B",
         "iplCatCd": "IPL1",
         "tlCatCd": "TL",
         "exciseCatCd": "EXEEG",
         "taxblAmt": 180,
         "vatAmt": 24.83,
         "iplAmt": null,
         "tlAmt": null,
         "exciseAmt": null,
         "totAmt": 180
      }
   ]
}
 
Have you considered using an ado disconnected recordset rather than caching
 
Do you mean between 10 and 50 records?

Yes and even more depending on the number of records or lines
 
Have you considered using an ado disconnected recordset rather than caching

The entire program is using DAO to switch to ADO means reprograming the codes again and chances of errors is too high, besides that I thought that ADO was replaced by DAO by Microsoft themselves.
 
nector said:
Have you considered using an ado disconnected recordset rather than caching

The entire program is using DAO to switch to ADO means reprograming the codes again and chances of errors is too high, besides that
I thought that ADO was replaced by DAO by Microsoft themselves.
Click to expand...
Microsoft did make such a move a couple of decades ago. It never succeeded and DAO regained prominence. It's no longer an argument for ADO itself.

There are other advantages to ADO, though, for situations where it makes sense, such as disconnected recordsets.
 
I don't know what you are doing. Are you creating a string or writing a text file in the above format? I have exports of HUGE text files. They can run to a half million rows because the EDI transactions can be 20 lines each which equals 20 records times thousands of transactions. This process only takes a few minutes.
 
You must log in or register to reply here.

Similar threads

N
VBA Code error on the counter
Replies
5
Views
184
cheekybuddha
cheekybuddha
N
Solved Progress meter for reports & queries in MS Access
Replies
16
Views
748
tvanstiphout
T
N
Solved Big variation when sending data through Cloud SQL Server Vs MS Access
Replies
10
Views
645
Pat Hartman
P
N
Solved How to grab fields from Json string to be part of the invoice
Replies
14
Views
766
Edgar_
E
N
Solved Cleaning Up the recordset after use in MS Access
Replies
7
Views
637
gemma-the-husky
gemma-the-husky

Users who are viewing this thread

Total: 2 (members: 0, guests: 2)
Back
Top Bottom