Option Explicit
Const NF As String = "NOT FOUND"
Option Base 1
Dim MyRequest As MSXML2.XMLHTTP60
Dim r1$, r2$, r3$, r4$, r5$, r6$, r7$, r8$
Dim NextURL
Dim ItemsCount&
Sub STk()
r1 = Chr(34)
r2 = Chr(58)
r3 = Chr(123)
r4 = Chr(125)
r5 = Chr(91)
r6 = Chr(93)
r7 = Chr(33)
r8 = Chr(44)
End Sub
Sub StartPars()
Const MassLC As Integer = 30
Dim MyRequest
Dim mass()
Dim x&, y&, z&, mC&, rC&
Dim tmpCol As Collection
Dim tmpCol2 As Collection
Dim VAL As Variant
Dim FirstLoop As Boolean
Dim isDate As Boolean
Set MyRequest = New MSXML2.XMLHTTP60
STk
NextURL = StURL
If Not IsEmpty([A1]) Then Range("A1").Resize(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column).ClearContents
rC = 1
FirstLoop = True
isDate = False
With MyRequest
Do
.Open "GET", NextURL
.SetRequestHeader "Host", "5ka.ru"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/62.0.3202.94 Safari/537.36"
.SetRequestHeader "X-Requested-With", "XMLHttpRequest"
.send
Set tmpCol = GetParsCol(.ResponseText)
If FirstLoop Then ReDim mass(ItemsCount + 10, MassLC): FirstLoop = False
For x = 1 To tmpCol.Count
rC = rC + 1
Set tmpCol2 = ReplVal(tmpCol.Item(x))
For y = 1 To tmpCol2.Count
mC = 0
For Each VAL In Split(tmpCol2.Item(y), ":")
mC = mC + 1
Select Case mC
Case 1
For z = 1 To MassLC
isDate = Not IsError(Application.Search("date", VAL))
If mass(1, z) = VAL Then Exit For
If IsEmpty(mass(1, z)) Then mass(1, z) = VAL: Exit For
Next
Case 2: If isDate Then mass(rC, z) = DateFromUnix(VAL) Else mass(rC, z) = VAL
End Select
Next
Next
Next
Loop While NextURL <> "null"
Range("A1").Resize(UBound(mass), MassLC) = mass
End With
End Sub
Function ReplVal(vStr As String) As Collection
Dim VAL
Dim kk As New Collection
Dim kk2 As New Collection
Dim rVal$
Dim KeyW
Dim mC%
Dim x&, y&, z&
Dim ANC As Boolean
kk2.Add Chr(34)
kk2.Add Chr(123)
kk2.Add Chr(125)
kk2.Add Chr(91)
kk2.Add Chr(93)
On Error Resume Next
For Each VAL In Split(vStr, r8 & r1)
rVal = VAL
For x = 1 To kk2.Count: rVal = Replace(rVal, kk2.Item(x), ""): Next
kk.Add rVal
Next
Set kk2 = Nothing
kk2.Add "image_small"
kk2.Add "image_big"
kk2.Add "date_start"
kk2.Add "date_end"
kk2.Add "special_price"
kk2.Add "regular_price"
kk2.Add "discount_percent"
kk2.Add "id"
kk2.Add "name"
z = kk.Count
For x = 1 To z
ANC = False
mC = 0
For Each VAL In Split(kk.Item(x), r2)
mC = mC + 1
For y = 1 To kk2.Count
If mC = 1 Then
If VAL = kk2.Item(y) Then ANC = True: Exit For
End If
Next
If mC = 1 And Not ANC Then kk.Remove (x): x = x - 1: z = z - 1: Exit For
If mC = 1 And ANC Then Exit For
Next
Next
Set ReplVal = kk
End Function
Function DateFromUnix(s As Variant) As Date
Dim d As Double
If (Len(s) = 13) Then
d = CDbl(Left(s, 10))
If Int(Mid(s, 11, 3) >= 500) Then d = d + 1
ElseIf (Len(s) = 10) Then
d = CDbl(s)
Else
DateFromUnix = CVErr(xlErrValue)
Exit Function
End If
DateFromUnix = DateAdd("s", d, DateSerial(1970, 1, 1))
End Function
Function GetParsCol(ParseResponse As String) As Collection
Dim d$
Dim st&, et&, cc&, mC&
Dim tmpCol As New Collection
Dim VAL, VAL2
Dim FirstLoop As Boolean
Dim isFnd As Boolean
d = r3 & r1 & "shopitem_categories" & r1 & r2 & r5
FirstLoop = True
isFnd = False
On Error GoTo errH
Do
st = Application.WorksheetFunction.Search(d, ParseResponse, 1)
If FirstLoop Then
FirstLoop = False
For Each VAL In Split(Left(ParseResponse, st), ",")
mC = 0
For Each VAL2 In Split(Left(VAL, st), r1 & r2)
mC = mC + 1
Select Case VAL2
Case r3 & r1 & "count": cc = 1
Case r1 & "next": cc = 2
End Select
If mC = 2 Then
Select Case cc
Case 1: ItemsCount = CDbl(Replace(VAL2, r1, ""))
Case 2: NextURL = Replace(VAL2, r1, ""): isFnd = True: Exit For
End Select
End If
Next
If isFnd Then Exit For
Next
End If
ParseResponse = Right(ParseResponse, Len(ParseResponse) - st - Len(d) + 1)
et = Application.WorksheetFunction.Search(d, ParseResponse, 1)
tmpCol.Add Left(ParseResponse, et - 2)
Loop While st > 0
Exit Function
errH:
Set GetParsCol = tmpCol
End Function
