|
2楼上大神对不住了,仅供参考
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Option Explicit
'Const wq As Long = 10
Sub kong()
Dim xmlHttp As Object
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
On Error Resume Next
Dim surl, strUrl1
Dim w, b, j, wq
wq = ActiveSheet.Cells(Rows.Count, "a").End(3).Row
w = 2
b = 0
j = 1
Dim arr(1 To 1000, 1 To 2)
Do While w < wq + 1
' 降低访问次数
' Sleep 20
If ActiveSheet.Cells(w, 1) <> "" Then
surl = ActiveSheet.Cells(w, 1)
With xmlHttp
.Open "GET", surl, False
.Send
Do While xmlHttp.readyState <> 4
DoEvents
Loop
strUrl1 = StrConv(.responsebody, vbUnicode)
Dim s() As String
s = Split(StrConv(.responsebody, vbUnicode), "{""hiRes"":")
Dim a
If Split(s(1), ",""")(0) <> "null" Then
a = 1
Do While a < UBound(s) + 1
arr(j, 1) = Split(Split(s(a), """")(1), """,""")(0)
arr(j, 2) = surl
j = j + 1
a = a + 1
Loop
End If
If Split(s(1), ",""")(0) = "null" Then
a = 1
Do While a < UBound(s) + 1
arr(j, 1) = Split(Split(s(a), "large"":""")(1), """,""")(0)
arr(j, 2) = surl
j = j + 1
a = a + 1
Loop
End If
End With
Erase s()
End If
w = w + 1
Loop
ActiveSheet.Range("c2").Resize(UBound(arr), 2) = arr
End Sub
|
-
|