阿根廷超市网页刮 [英] Argentina supermarket web scraping
本文介绍了阿根廷超市网页刮的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
如果没有Cookie标题，POST XHR对我来说不起作用。因此，我必须添加额外的HEAD XHR来首先检索 ASP.NET_SessionId cookie，服务器版本XMLHTTP用于控制cookie。返回Cookie的唯一响应标头是来自
- 检索的JSON字符串应该被解析两次，因为它包含第二个有效负载JSON包裹在
d属性的第一个JSON。 - 将解析的JSON对象转换为以2d数组表示的表格形式。
- 将数组输出到工作表。您可以通过直接访问数组来执行进一步处理。
对于以下所示的网页：
我的输出如下：
将以下代码放入VBA项目标准模块中：
< pre class =lang-vb prettyprint-override>
Option Explicit
Sub GetData（）
Dim sCookie As String
Dim sPayLoad As String
Dim sCont As String
Dim vJSON As Variant
Dim sState As String
Dim y As Long
Dim sSection As Variant
Dim aData（）
Dim aHeader（）
'从站点获取cookie
使用CreateObject（MSXML 2.ServerXMLHTTP）
。打开HEAD，https://www.disco.com.ar/Login/PreHome.aspx，False
。发送
sCookie = .getAllResponseHeaders
结束
sCookie = Split（sCookie，Set-Cookie：，2）（1）
sCookie = Split（sCookie，;，2）（0）
'检索JSON数据
sPayLoad ={IdMenu：21063，textoBusqueda：，producto：，marca：，& _
pager：，ordenamiento：0，precioDesde：，precioHasta：
使用CreateObject（MSXML2.ServerXMLHTTP）
。打开POST，https://www.disco.com.ar/Comprar/HomeService.aspx/ObtenerArticulosPorDescripcionMarcaFamiliaLevex，False
.SetRequestHeaderAccept，application / json，text / javascript，* / * ; q = 0.01
.SetRequestHeaderContent-Type，application / json; charset = utf-8
.SetRequestHeaderContent-Length，Len（sPayLoad）
.SetRequestHeader Cookie，sCookie
。发送CStr（sPayLoad）
sCont = .responseText
结束
'解析JSON响应
JSON.Parse sCont，vJSON，sState
sCont = vJSON.Item（d）
JSON.Parse sCont，vJSON，sState
'输出表
表（1）.Cells.Delete
y = 1
对于每个sSection In Array（Tipo，Marca，Precio，ResultadosBusquedaLevex，ArticulosSugereridos）
JSON.ToArray vJ （1）
.Cells（y，1）.Value = sSection
OutputArray .Cells（y + 1，1），aHeader
Output2DArray .Cells（y + 2，1），aData
.Cells.Columns.AutoFit
结束
y = y + UBound（aData，1）+ 4
Next
End Sub
Sub OutputArray（oDstRng As Range，aCells As Variant）
带oDstRng
.Parent.Select
使用.Resize（_
1，_
UBound（aCells） - LBound（aCells）+ 1）
.NumberFormat =@
.Value = aCells
结束
结束
End Sub
Sub Output2DArray（oDstRng As Range，aCells As Variant）
With oDstRng
.Parent.Select
使用.Resize（_
UBound（aCells，1） - LBound（aCells，1）+ 1，_
UBound（aCells，2） - LBound （aCells，2）+ 1）
.NumberFormat =@
.Value = aCells
结束
结束
End Sub
再创建一个标准模块，将其命名为 JSON 并将以下代码放入其中，代码提供JSON处理功能：
Option Explicit
Private sBuffer As String
私有oTokens作为对象
私有oRegEx作为对象
私有bMatch作为布尔
私有oChunks作为对象
私有oHeader作为对象
私有aData（）为变量
私人我长期
子解析（ByVal sSample As String，vJSON As Variant，sState As String）
'Backus-Naur表示基于JSON解析器实现on RegEx
'输入：
'sSample - 源JSON字符串
'输出：
'vJson - 创建的对象或数组返回为结果
'sState - string对象|数组|错误依赖g处理
sBuffer = sSample
设置oTokens = CreateObject（Scripting.Dictionary）
设置oRegEx = CreateObject（VBScript.RegExp）
带有oRegEx '基于规范的模式http://www.json.org/
.Global = True
.MultiLine = True
.IgnoreCase = True'Unspecified True，False，Null accepted
.Pattern =（？：'[^'] *'|（？：\\| [^]）*）（？= \s * [，\： \] \}]）'双引号字符串，未指定引用的字符串
令牌s $ $ $ $ $ $ $ $ d * | \.\d + | \d +）（？：e [+ - ]？\d +）？（？= \s * [，\] \}]）'符号数
令牌d
.Pattern =\b（？：true | false | null）（？= \s * [，\] \}]） true，false，null
表示c
.Pattern =\b [A-Za-z_] \w *（？= \s * \ :)'未指定的非双引号rty名称接受
令牌n
.Pattern =\s +
sBuffer = .Replace（sBuffer，）'删除不必要的空格
.MultiLine = False
Do
bMatch = False
.Pattern =< \d +（？：[sn]）> \：< \d + [codas]> 'Object property structure
Tokenizep
.Pattern =\ {（？：< \d + p>（？：，< \d + p>）*）？ \}'对象结构
Tokenizeo
.Pattern =\ [（？：< \d + [codas]>（？：，< \d + ] *）？\]'数组结构
令牌a
循环while bMatch
.Pattern =^&\d + [oa]> $ '顶级对象结构，未指定的数组接受
如果.Test（sBuffer）和oTokens.Exists（sBuffer）然后
检索sBuffer，vJSON
sState = IIf（IsObject（vJSON），对象，Array）
Else
vJSON = Null
sState =Error
End If
End With
Set oTokens = Nothing
set oRegEx = Nothing
End Sub
Private Sub Tokenize（sType）
Dim aContent（）As String
Dim lCopyIndex As Long
Dim i As Long
Dim sKey As String
带oRegEx.Execute（sBuffer）
如果.Count = 0然后退出Sub
ReDim aContent（0 To .Count - 1）
lCopyIndex = 1
For i = 0 To .Count - 1
With .Item（i）
sKey =< &安培; oTokens.Count& sType& > 中
oTokens（sKey）= .Value
aContent（i）= Mid（sBuffer，lCopyIndex，.FirstIndex - lCopyIndex + 1）& sKey
lCopyIndex = .FirstIndex + .Length + 1
结束
下一个
结束
sBuffer = Join（aContent，）& Mid（sBuffer，lCopyIndex，Len（sBuffer） - lCopyIndex + 1）
bMatch = True
End Sub
Private Sub Retrieve（sTokenKey，vTransfer）
Dim sTokenValue As String
Dim sName As String
Dim vValue As Variant
Dim aTokens（）As String
Dim i As Long
sTokenValue = oTokens（sTokenKey）
与oRegEx
.Global = True
选择案例左（右（sTokenKey，2），1）
案例o
设置vTransfer = CreateObject（Scripting.Dictionary）
aTokens = Split（sTokenValue，<）
对于i = 1 To UBound（aTokens）
检索< &安培;分割（aTokens（i），>，2）（0）& >，vTransfer
下一个
案例p
aTokens = Split（sTokenValue，<，4）
检索< &安培;分割（aTokens（1），>，2）（0）& >，sName
检索< &安培;分割（aTokens（2），>，2）（0）& >，vValue
如果IsObject（vValue）然后
设置vTransfer（sName）= vValue
Else
vTransfer（sName）= vValue
End If
Casea
aTokens = Split（sTokenValue，<）
如果UBound（aTokens）= 0然后
vTransfer = Array（）
Else
ReDim vTransfer（0到UBound（aTokens） - 1）
对于i = 1 To UBound（aTokens）
检索< &安培;分割（aTokens（i），>，2）（0）& >，vValue
如果IsObject（vValue）然后
设置vTransfer（i - 1）= vValue
Else
vTransfer（i - 1）= vValue
结束如果
下一个
结束如果
案例n
vTransfer = sTokenValue
案例
vTransfer =替换（替换（替换替换（替换（_
中（sTokenValue，2，Len（sTokenValue） - 2），_
\，），_
\\，\），_
\ /，/），_
\b，Chr（8）），_
\f，Chr（12）），_
\\\
，vbLf），_
\r，vbCr），_
\t ，vbTab）
.Global = False
.Pattern =\\u [0-9a-fA-F] {4}
尽管.Test（vTransfer）
vTransfer = .Replace（vTransfer，ChrW（（& H&右（.Execute（vTransfer）（0）.Value，4））* 1））
循环
案例d
vTransfer =评估（sTokenValue）
案例c
选择案例LCase（sTokenValue）
案例true
vTransfer = True
案例false
vTransfer = False
案例null
vTransfer = Null
结束选择
结束选择
结束
End Sub
函数序列化（vJSON As Variant）As String
设置oChunks = CreateObject（Scripting.Dictionary）
SerializeElement vJSON
Serialize = Join（oChunks.Items（），）
设置oChunks = Nothing
结束函数
Private Sub SerializeElement（vElement As Variant，ByVal sIndent As String）
Dim aKeys（）As Variant
Dim i As Long
W ith oChunks
选择案例VarType（vElement）
案例vbObject
如果vElement.Count = 0然后
.Item（.Count）={}
Else
.Item（.Count）={& vbCrLf
aKeys = vElement.Keys
For i = 0 To UBound（aKeys）
.Item（.Count）= sIndent& vbTab& & aKeys（i）& & ：
SerializeElement vElement（aKeys（i）），sIndent& vbTab
如果不是（i = UBound（aKeys））然后.Item（.Count）=，
.Item（.Count）= vbCrLf
下一个
.Item .Count）= sIndent& }
End If
Case is> = vbArray
如果UBound（vElement）= -1然后
.Item（.Count）=[]
Else
.Item（.Count）=[& vbCrLf
对于i = 0到UBound（vElement）
.Item（.Count）= sIndent& vbTab
SerializeElement vElement（i），sIndent& vbTab
如果不是（i = UBound（vElement））Then .Item（.Count）=，'sResult = sResult& ，
.Item（.Count）= vbCrLf
下一个
.Item（.Count）= sIndent& ]
End If
案例vbInteger，vbLong
.Item（.Count）= vElement
案例vbSingle，vbDouble
.Item（.Count）=替换（ vElement，，，。）
案例vbNull
.Item（.Count）=null
案例vbBoolean
.Item（.Count）= IIf（vElement ，true，false）
Case Else
.Item（.Count）=& _
替换（替换（替换（替换（替换（替换（vElement，_
\，\\），_
，\），_
/，\ /），_
Chr（8），\b），_
Chr ），_
vbLf，\\\
），_
vbCr，\r），_
vbTab，\t） &安培; _
结束选择
结束
End Sub
函数ToString（vJSON As Variant）As String
选择案例VarType（vJSON）
案例vbObject，Is> = vbArray
设置oChunks = CreateObject（Scripting.Dictionary）
ToStringElement vJSON
oChunks.Remove 0
ToString = Join（oChunks.Items（），）
设置oChunks = Nothing
案例vbNull
ToString =Null
案例vbBoolean
ToString = IIf（vJSON，True，False）
案例Else
ToString = CStr（vJSON）
结束选择
结束函数
Private Sub ToStringElement（vElement As Variant，ByVal sIndent As String）
Dim aKeys（）As Variant
Dim i As Long
与oChunks
选择案例VarType（vElement）
案例vbObject
如果vE lement.Count = 0然后
.Item（.Count）=''
Else
.Item（.Count）= vbCrLf
aKeys = vElement.Keys
对于i = 0到UBound（aKeys）
.Item（.Count）= sIndent& aKeys（i）& ：
ToStringElement vElement（aKeys（i）），sIndent& vbTab
如果不是（i = UBound（aKeys））然后.Item（.Count）= vbCrLf
下一个
结束If
案例是> = vbArray
如果UBound（vElement）= -1然后
.Item（.Count）=''
Else
.Item（.Count）= vbCrLf
对于i = 0到UBound （vElement）
.Item（.Count）= sIndent&我& ：
ToStringElement vElement（i），sIndent& vbTab
如果不是（i = UBound（vElement））然后.Item（.Count）= vbCrLf
下一个
结束如果
案例vbNull
.Item（.Count ）=Null
案例vbBoolean
.Item（.Count）= IIf（vElement，True，False）
案例Else
.Item（.Count） = CStr（vElement）
结束选择
结束
End Sub
Sub ToArray（vJSON As Variant，aRows（）As Variant，aHeader ）作为变体）
'输入：
'vJSON - 包含行数据的数组或对象
'输出：
'aData - 表示JSON数据的2d数组
'aHeader - 1d数组的属性名称
Dim sName As Variant
设置oHeader = CreateObject（Scripting.Dictionary）
选择案例VarType（vJSON ）
案例vbObject
如果vJSON.Count> 0然后
ReDim aData（0到vJSON.Count - 1，0到0）
oHeader（＃）= 0
i = 0
对于每个sName在vJSON
aData（i，0）=＃& sName
ToArrayElement vJSON（sName），
i = i + 1
下一个
Else
ReDim aData（0到0，0到0）
结束如果
案例是> = vbArray
如果UBound（vJSON）> = 0然后
ReDim aData（0到UBound（vJSON），0到0）
对于i = 0到UBound（vJSON）
ToArrayElement vJSON（i），
下一个
Else
ReDim aData（0到0，0到0）
结束If
案例Else
ReDim aData（0到0，0到0）
aData（0，0）= ToString（vJSON）
结束选择
aHeader = oHeader。 key（）
设置oHeader = Nothing
aRows = aData
擦除aData
End Sub
Private Sub ToArrayElement（vElement As Variant， sFieldName As String）
Dim sName As Variant
Dim j As Long
选择案例VarType（vElement）
案例vbObject对象的集合
对于每个sName在vElement中
ToArrayElement vElement（sName），sFieldName& IIf（sFieldName =，，_）& sName
下一个
案例是> = vbArray'数组集合
对于j = 0到UBound（vElement）
ToArrayElement vElement（j），sFieldName& IIf（sFieldName =，，_）& ＃& j
下一个
案例Else
如果不是oHeader.Exists（sFieldName）然后
oHeader（sFieldName）= oHeader.Count
如果UBound（aData，2） oHeader.Count - 1然后ReDim保存aData（0到UBound（aData，1），0 To oHeader.Count - 1）
End If
j = oHeader（sFieldName）
aData（i， j）= ToString（vElement）
结束选择
End Sub
I´m trying to scrape data from website:
https://www.disco.com.ar/Comprar/Home.aspx#_atCategory=false&_atGrilla=true&_id=21063
via a macro in Excel 2013, like real-time price, product name and image.
I have tried excel web query but it does not works.
Is there a way of doing this?
解决方案
There is the example showing how the data could be retrieved from the website using XHRs and JSON parsing, it consists of several steps.
- Retrieve the data.
I looked into a little with XHRs using Chrome Developer Tools Network tab. Most relevant data I found is JSON string returned by POST XHR from https://www.disco.com.ar/Comprar/HomeService.aspx/ObtenerLimiteDeProductos
The POST XHR doesn't work for me without the cookie header. Thus I have to add additional HEAD XHR to retrieve ASP.NET_SessionId cookie first, server version XMLHTTP used to control cookies. The only response headers returning the cookie is GET XHR from https://www.disco.com.ar/Login/PreHome.aspx
- Retrieved JSON string should be parsed twice as it contains the second payload JSON wrapped in
dproperty of the first JSON. - Convert parsed JSON object into table-like form presented in 2d-arrays.
- Output the arrays to the worksheet. You can perform further processing with direct access to the arrays.
For the webpage shown below:
The output for me is as follows:
Put the below code into VBA Project standard module:
Option Explicit
Sub GetData()
Dim sCookie As String
Dim sPayLoad As String
Dim sCont As String
Dim vJSON As Variant
Dim sState As String
Dim y As Long
Dim sSection As Variant
Dim aData()
Dim aHeader()
' Get cookie from the site
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "HEAD", "https://www.disco.com.ar/Login/PreHome.aspx", False
.Send
sCookie = .getAllResponseHeaders
End With
sCookie = Split(sCookie, "Set-Cookie: ", 2)(1)
sCookie = Split(sCookie, ";", 2)(0)
' Retrieve JSON data
sPayLoad = "{IdMenu:""21063"",textoBusqueda:"""", producto:"""", marca:"""", " & _
"pager:"""", ordenamiento:0, precioDesde:"""", precioHasta:""""}"
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", "https://www.disco.com.ar/Comprar/HomeService.aspx/ObtenerArticulosPorDescripcionMarcaFamiliaLevex", False
.SetRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
.SetRequestHeader "Content-Type", "application/json; charset=utf-8"
.SetRequestHeader "Content-Length", Len(sPayLoad)
.SetRequestHeader "Cookie", sCookie
.Send CStr(sPayLoad)
sCont = .responseText
End With
' Parse JSON response
JSON.Parse sCont, vJSON, sState
sCont = vJSON.Item("d")
JSON.Parse sCont, vJSON, sState
' Output tables
Sheets(1).Cells.Delete
y = 1
For Each sSection In Array("Tipo", "Marca", "Precio", "ResultadosBusquedaLevex", "ArticulosSugereridos")
JSON.ToArray vJSON.Item(sSection), aData, aHeader
With Sheets(1)
.Cells(y, 1).Value = sSection
OutputArray .Cells(y + 1, 1), aHeader
Output2DArray .Cells(y + 2, 1), aData
.Cells.Columns.AutoFit
End With
y = y + UBound(aData, 1) + 4
Next
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
1, _
UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "@"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "@"
.Value = aCells
End With
End With
End Sub
Create one more standard module, name it JSON and put the below code into it, this code provides JSON processing functionality:
Option Explicit
Private sBuffer As String
Private oTokens As Object
Private oRegEx As Object
Private bMatch As Boolean
Private oChunks As Object
Private oHeader As Object
Private aData() As Variant
Private i As Long
Sub Parse(ByVal sSample As String, vJSON As Variant, sState As String)
' Backus–Naur form JSON parser implementation based on RegEx
' Input:
' sSample - source JSON string
' Output:
' vJson - created object or array to be returned as result
' sState - string Object|Array|Error depending on processing
sBuffer = sSample
Set oTokens = CreateObject("Scripting.Dictionary")
Set oRegEx = CreateObject("VBScript.RegExp")
With oRegEx ' Patterns based on specification http://www.json.org/
.Global = True
.MultiLine = True
.IgnoreCase = True ' Unspecified True, False, Null accepted
.Pattern = "(?:'[^']*'|""(?:\\""|[^""])*"")(?=\s*[,\:\]\}])" ' Double-quoted string, unspecified quoted string
Tokenize "s"
.Pattern = "[+-]?(?:\d+\.\d*|\.\d+|\d+)(?:e[+-]?\d+)?(?=\s*[,\]\}])" ' Number, E notation number
Tokenize "d"
.Pattern = "\b(?:true|false|null)(?=\s*[,\]\}])" ' Constants true, false, null
Tokenize "c"
.Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' Unspecified non-double-quoted property name accepted
Tokenize "n"
.Pattern = "\s+"
sBuffer = .Replace(sBuffer, "") ' Remove unnecessary spaces
.MultiLine = False
Do
bMatch = False
.Pattern = "<\d+(?:[sn])>\:<\d+[codas]>" ' Object property structure
Tokenize "p"
.Pattern = "\{(?:<\d+p>(?:,<\d+p>)*)?\}" ' Object structure
Tokenize "o"
.Pattern = "\[(?:<\d+[codas]>(?:,<\d+[codas]>)*)?\]" ' Array structure
Tokenize "a"
Loop While bMatch
.Pattern = "^<\d+[oa]>$" ' Top level object structure, unspecified array accepted
If .Test(sBuffer) And oTokens.Exists(sBuffer) Then
Retrieve sBuffer, vJSON
sState = IIf(IsObject(vJSON), "Object", "Array")
Else
vJSON = Null
sState = "Error"
End If
End With
Set oTokens = Nothing
Set oRegEx = Nothing
End Sub
Private Sub Tokenize(sType)
Dim aContent() As String
Dim lCopyIndex As Long
Dim i As Long
Dim sKey As String
With oRegEx.Execute(sBuffer)
If .Count = 0 Then Exit Sub
ReDim aContent(0 To .Count - 1)
lCopyIndex = 1
For i = 0 To .Count - 1
With .Item(i)
sKey = "<" & oTokens.Count & sType & ">"
oTokens(sKey) = .Value
aContent(i) = Mid(sBuffer, lCopyIndex, .FirstIndex - lCopyIndex + 1) & sKey
lCopyIndex = .FirstIndex + .Length + 1
End With
Next
End With
sBuffer = Join(aContent, "") & Mid(sBuffer, lCopyIndex, Len(sBuffer) - lCopyIndex + 1)
bMatch = True
End Sub
Private Sub Retrieve(sTokenKey, vTransfer)
Dim sTokenValue As String
Dim sName As String
Dim vValue As Variant
Dim aTokens() As String
Dim i As Long
sTokenValue = oTokens(sTokenKey)
With oRegEx
.Global = True
Select Case Left(Right(sTokenKey, 2), 1)
Case "o"
Set vTransfer = CreateObject("Scripting.Dictionary")
aTokens = Split(sTokenValue, "<")
For i = 1 To UBound(aTokens)
Retrieve "<" & Split(aTokens(i), ">", 2)(0) & ">", vTransfer
Next
Case "p"
aTokens = Split(sTokenValue, "<", 4)
Retrieve "<" & Split(aTokens(1), ">", 2)(0) & ">", sName
Retrieve "<" & Split(aTokens(2), ">", 2)(0) & ">", vValue
If IsObject(vValue) Then
Set vTransfer(sName) = vValue
Else
vTransfer(sName) = vValue
End If
Case "a"
aTokens = Split(sTokenValue, "<")
If UBound(aTokens) = 0 Then
vTransfer = Array()
Else
ReDim vTransfer(0 To UBound(aTokens) - 1)
For i = 1 To UBound(aTokens)
Retrieve "<" & Split(aTokens(i), ">", 2)(0) & ">", vValue
If IsObject(vValue) Then
Set vTransfer(i - 1) = vValue
Else
vTransfer(i - 1) = vValue
End If
Next
End If
Case "n"
vTransfer = sTokenValue
Case "s"
vTransfer = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
Mid(sTokenValue, 2, Len(sTokenValue) - 2), _
"\""", """"), _
"\\", "\"), _
"\/", "/"), _
"\b", Chr(8)), _
"\f", Chr(12)), _
"\n", vbLf), _
"\r", vbCr), _
"\t", vbTab)
.Global = False
.Pattern = "\\u[0-9a-fA-F]{4}"
Do While .Test(vTransfer)
vTransfer = .Replace(vTransfer, ChrW(("&H" & Right(.Execute(vTransfer)(0).Value, 4)) * 1))
Loop
Case "d"
vTransfer = Evaluate(sTokenValue)
Case "c"
Select Case LCase(sTokenValue)
Case "true"
vTransfer = True
Case "false"
vTransfer = False
Case "null"
vTransfer = Null
End Select
End Select
End With
End Sub
Function Serialize(vJSON As Variant) As String
Set oChunks = CreateObject("Scripting.Dictionary")
SerializeElement vJSON, ""
Serialize = Join(oChunks.Items(), "")
Set oChunks = Nothing
End Function
Private Sub SerializeElement(vElement As Variant, ByVal sIndent As String)
Dim aKeys() As Variant
Dim i As Long
With oChunks
Select Case VarType(vElement)
Case vbObject
If vElement.Count = 0 Then
.Item(.Count) = "{}"
Else
.Item(.Count) = "{" & vbCrLf
aKeys = vElement.Keys
For i = 0 To UBound(aKeys)
.Item(.Count) = sIndent & vbTab & """" & aKeys(i) & """" & ": "
SerializeElement vElement(aKeys(i)), sIndent & vbTab
If Not (i = UBound(aKeys)) Then .Item(.Count) = ","
.Item(.Count) = vbCrLf
Next
.Item(.Count) = sIndent & "}"
End If
Case Is >= vbArray
If UBound(vElement) = -1 Then
.Item(.Count) = "[]"
Else
.Item(.Count) = "[" & vbCrLf
For i = 0 To UBound(vElement)
.Item(.Count) = sIndent & vbTab
SerializeElement vElement(i), sIndent & vbTab
If Not (i = UBound(vElement)) Then .Item(.Count) = "," 'sResult = sResult & ","
.Item(.Count) = vbCrLf
Next
.Item(.Count) = sIndent & "]"
End If
Case vbInteger, vbLong
.Item(.Count) = vElement
Case vbSingle, vbDouble
.Item(.Count) = Replace(vElement, ",", ".")
Case vbNull
.Item(.Count) = "null"
Case vbBoolean
.Item(.Count) = IIf(vElement, "true", "false")
Case Else
.Item(.Count) = """" & _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(vElement, _
"\", "\\"), _
"""", "\"""), _
"/", "\/"), _
Chr(8), "\b"), _
Chr(12), "\f"), _
vbLf, "\n"), _
vbCr, "\r"), _
vbTab, "\t") & _
""""
End Select
End With
End Sub
Function ToString(vJSON As Variant) As String
Select Case VarType(vJSON)
Case vbObject, Is >= vbArray
Set oChunks = CreateObject("Scripting.Dictionary")
ToStringElement vJSON, ""
oChunks.Remove 0
ToString = Join(oChunks.Items(), "")
Set oChunks = Nothing
Case vbNull
ToString = "Null"
Case vbBoolean
ToString = IIf(vJSON, "True", "False")
Case Else
ToString = CStr(vJSON)
End Select
End Function
Private Sub ToStringElement(vElement As Variant, ByVal sIndent As String)
Dim aKeys() As Variant
Dim i As Long
With oChunks
Select Case VarType(vElement)
Case vbObject
If vElement.Count = 0 Then
.Item(.Count) = "''"
Else
.Item(.Count) = vbCrLf
aKeys = vElement.Keys
For i = 0 To UBound(aKeys)
.Item(.Count) = sIndent & aKeys(i) & ": "
ToStringElement vElement(aKeys(i)), sIndent & vbTab
If Not (i = UBound(aKeys)) Then .Item(.Count) = vbCrLf
Next
End If
Case Is >= vbArray
If UBound(vElement) = -1 Then
.Item(.Count) = "''"
Else
.Item(.Count) = vbCrLf
For i = 0 To UBound(vElement)
.Item(.Count) = sIndent & i & ": "
ToStringElement vElement(i), sIndent & vbTab
If Not (i = UBound(vElement)) Then .Item(.Count) = vbCrLf
Next
End If
Case vbNull
.Item(.Count) = "Null"
Case vbBoolean
.Item(.Count) = IIf(vElement, "True", "False")
Case Else
.Item(.Count) = CStr(vElement)
End Select
End With
End Sub
Sub ToArray(vJSON As Variant, aRows() As Variant, aHeader() As Variant)
' Input:
' vJSON - Array or Object which contains rows data
' Output:
' aData - 2d array representing JSON data
' aHeader - 1d array of property names
Dim sName As Variant
Set oHeader = CreateObject("Scripting.Dictionary")
Select Case VarType(vJSON)
Case vbObject
If vJSON.Count > 0 Then
ReDim aData(0 To vJSON.Count - 1, 0 To 0)
oHeader("#") = 0
i = 0
For Each sName In vJSON
aData(i, 0) = "#" & sName
ToArrayElement vJSON(sName), ""
i = i + 1
Next
Else
ReDim aData(0 To 0, 0 To 0)
End If
Case Is >= vbArray
If UBound(vJSON) >= 0 Then
ReDim aData(0 To UBound(vJSON), 0 To 0)
For i = 0 To UBound(vJSON)
ToArrayElement vJSON(i), ""
Next
Else
ReDim aData(0 To 0, 0 To 0)
End If
Case Else
ReDim aData(0 To 0, 0 To 0)
aData(0, 0) = ToString(vJSON)
End Select
aHeader = oHeader.Keys()
Set oHeader = Nothing
aRows = aData
Erase aData
End Sub
Private Sub ToArrayElement(vElement As Variant, sFieldName As String)
Dim sName As Variant
Dim j As Long
Select Case VarType(vElement)
Case vbObject ' collection of objects
For Each sName In vElement
ToArrayElement vElement(sName), sFieldName & IIf(sFieldName = "", "", "_") & sName
Next
Case Is >= vbArray ' collection of arrays
For j = 0 To UBound(vElement)
ToArrayElement vElement(j), sFieldName & IIf(sFieldName = "", "", "_") & "#" & j
Next
Case Else
If Not oHeader.Exists(sFieldName) Then
oHeader(sFieldName) = oHeader.Count
If UBound(aData, 2) < oHeader.Count - 1 Then ReDim Preserve aData(0 To UBound(aData, 1), 0 To oHeader.Count - 1)
End If
j = oHeader(sFieldName)
aData(i, j) = ToString(vElement)
End Select
End Sub
这篇关于阿根廷超市网页刮的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
