Option Base 1
Option Explicit
Option Private Module
'====================================================================================================
Sub KSR()
Dim booksId, partsId, sectionsId, groupsId, bId, pId, sId, gId, b&, p&, s&, g&, r&
Dim x, arr, aRes() As String, fMech As Boolean
Dim dateNow$, tx$, t!, i&, ii&, n&, nContr&
t = Timer
dateNow = Format$(Date, "dd.MM.yyyy")
ReDim aRes(200000, 16) ' IDs for Book,Part,Sect,Gr, Row (1-5), Codes (6-10), Names (11-15) + Measure (#16) for Material
For Each arr In Array("ID", "Code", "Name") ' Headers for output array
For Each x In Array("Book", "Part", "Sect", "Group", "Row")
r = r + 1: aRes(1, r) = arr & " " & x
Next x
Next arr
r = r + 1: aRes(1, r) = "Meas": r = 1
booksId = "https://ksr.minstroyrf.ru/ksr-rest/classifier/books?date=" & dateNow
If Not PRDX_ParseGetOrPost(booksId) Then Stop
If Not REMatches(booksId) Then Stop
For Each bId In booksId
b = b + 1: bId = Mid$(bId, 6): partsId = "https://ksr.minstroyrf.ru/ksr-rest/classifier/parts_sections/" & bId & "?date=" & dateNow
If Not PRDX_ParseGetOrPost(partsId) Then Stop
Application.StatusBar = "Book #" & b & ". ID #" & bId
If bId = "76" Then ' если это книга 91, то в ней нет ЧАСТЕЙ
fMech = True: sectionsId = partsId: partsId = Array("null")
Else
fMech = False: If Not REMatches(partsId) Then Stop
' GoTo nxB ' for Debug 91st book
End If
For Each pId In partsId
If Not fMech Then
pId = Mid$(pId, 6): sectionsId = "https://ksr.minstroyrf.ru/ksr-rest/classifier/sections/" & pId & "?date=" & dateNow
If Not PRDX_ParseGetOrPost(sectionsId) Then Stop
End If
p = p + 1: If Not REMatches(sectionsId) Then Stop
For Each sId In sectionsId
s = s + 1: sId = Mid$(sId, 6): groupsId = "https://ksr.minstroyrf.ru/ksr-rest/classifier/groups/" & sId & "?date=" & dateNow
If Not PRDX_ParseGetOrPost(groupsId) Then Stop
If Not REMatches(groupsId) Then Stop
For Each gId In groupsId
g = g + 1: gId = Mid$(gId, 6): x = "https://ksr.minstroyrf.ru/ksr-rest/classifier/extlist"
If Not PRDX_ParseGetOrPost(x, "{""date"":""" & dateNow & """,""groupId"":" & gId & ",""page"":0,""length"":10000,""sidx"":""title"",""sord"":""ASC""}", "Content-Type", "application/json;charset=UTF-8") Then Err.Raise xlErrNA
tx = x: i = InStrRev(tx, "}],""totalRows"":"): If i = 0 Then Stop
nContr = Val(Mid$(tx, i + 15)): n = 0
ii = InStr(1, tx, "["): If i = 0 Then Stop
tx = Mid$(tx, ii + 1, i - ii + 1)
If fMech Then tx = Replace$(tx, "null", """null""")
arr = Split(tx, "{""id"":")
For Each x In arr
If Len(x) Then
r = r + 1: n = n + 1: tx = x
aRes(r, 1) = bId: aRes(r, 2) = pId: aRes(r, 3) = sId: aRes(r, 4) = gId ' fill ID's (except Row)
ii = InStr(1, tx, ",""title"":"""): If ii = 0 Then Stop
aRes(r, 5) = --Left$(tx, ii - 1): i = ii + 10 ' ID Row
ii = InStr(i + 1, tx, """,""code"":"""): If ii = 0 Then Stop
aRes(r, 15) = Mid$(tx, i, ii - i): i = ii + 10 ' Name Row
ii = InStr(i + 1, tx, """,""measure"":"""): If ii = 0 Then Stop
aRes(r, 10) = Mid$(tx, i, ii - i): i = ii + 13 ' Code Row
ii = InStr(i + 1, tx, """,""bookCode"":"""): If ii = 0 Then Stop
aRes(r, 16) = Mid$(tx, i, ii - i): i = ii + 14 ' Measure Row
ii = InStr(i + 1, tx, """,""bookTitle"":"""): If ii = 0 Then Stop
aRes(r, 6) = Mid$(tx, i, ii - i): i = ii + 15 ' Code Book
ii = InStr(i + 1, tx, """,""partCode"":"""): If ii = 0 Then Stop
aRes(r, 11) = Mid$(tx, i, ii - i): i = ii + 14 ' Name Book
ii = InStr(i + 1, tx, """,""partTitle"":"""): If ii = 0 Then Stop
aRes(r, 7) = Mid$(tx, i, ii - i): i = ii + 15 ' Code Part
ii = InStr(i + 1, tx, """,""sectionCode"":"""): If ii = 0 Then Stop
aRes(r, 12) = Mid$(tx, i, ii - i): i = ii + 17 ' Name Part
ii = InStr(i + 1, tx, """,""sectionTitle"":"""): If ii = 0 Then Stop
aRes(r, 8) = Mid$(tx, i, ii - i): i = ii + 18 ' Code Section
ii = InStr(i + 1, tx, """,""groupCode"":"""): If ii = 0 Then Stop
aRes(r, 13) = Mid$(tx, i, ii - i): i = ii + 15 ' Name Section
ii = InStr(i + 1, tx, """,""groupTitle"":"""): If ii = 0 Then Stop
aRes(r, 9) = Mid$(tx, i, ii - i): i = ii + 16 ' Code Group
ii = InStr(i + 1, tx, """}"): If ii = 0 Then Stop
aRes(r, 14) = Mid$(tx, i, ii - i) ' Name Group
End If
Next x
If n <> nContr Then Stop
Next gId
Next sId
Next pId
nxB:
Next bId
out: Application.StatusBar = False: Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(r, UBound(aRes, 2)).Value2 = aRes
MsgBox "DONE", vbInformation, Format(Timer - t, "0.00 sec")
End Sub
'169310,"title":"Детали коньковые перекрываемые для листов хризотилцементных волнистых прочих профилей","code":"23.65.12.01.1.01.01-1018","measure":"шт","bookCode":"01","bookTitle":"Материалы для строительных и дорожных работ","partCode":"01.1","partTitle":"Материалы, изделия и конструкции хризотилсодержащие","sectionCode":"01.1.01","sectionTitle":"Материалы, изделия и конструкции хризотилсодержащие","groupCode":"01.1.01.01","groupTitle":"Детали фасонные к листам хризотилцементным"},
'266904,"title":"Бульдозер 128,7 кВт (175 л.с.) в составе кабелеукладочной колонны","code":"28.92.21.91.01.01-001","measure":"маш.-ч","bookCode":"91","bookTitle":"Машины и механизмы","partCode":null,"partTitle":null,"sectionCode":"91.01","sectionTitle":"Машины для земляных работ","groupCode":"91.01.01","groupTitle":"Бульдозеры"},
'----------------------------------------------------------------------------------------------------
Private Function REMatches(tmpStr) As Boolean
Static RE As RegExp, fStatic As Boolean
If Not fStatic Then
fStatic = True: Set RE = New RegExp
RE.Global = True: RE.IgnoreCase = True: RE.MultiLine = True: RE.pattern = """id"":(\d+)"
End If
If RE.Test(tmpStr) Then Set tmpStr = RE.Execute(tmpStr): REMatches = True
End Function
'====================================================================================================
Function PRDX_ParseGetOrPost(tmpURL, Optional txSend$, Optional PostHead1$, Optional PostHead2$) As Boolean
Dim HTTP As New WinHttpRequest ' lib Microsoft WinHTTPService
Dim tx$, fPost As Boolean
If Len(PostHead1) Then fPost = True: tx = "POST" Else tx = "GET"
With HTTP
.Open tx, tmpURL, "False"
If fPost Then .setRequestHeader PostHead1, PostHead2
If Len(txSend) Then .Send txSend Else .Send
If .waitForResponse(5) Then tmpURL = .responseText: PRDX_ParseGetOrPost = True
End With
End Function
'==================================================================================================== |