网页抓取分享

onlycxb

renahu 发表于 2014-11-1 15:04
谁知道程序代码怎么发，才能左边带序号，而且最下面还有个“复制代码”？看着很漂亮啊

回复界面不是有个〈〉吗？填这里就可以了

VBA万岁

VBA万岁 发表于 2014-11-7 12:28
多谢onlycxb大侠分享！
分别用网抓及自定义函数获得城市拼音码，并取数如下：

自定义函数PinYin详见附件：

天气预报.zip (253.13 KB, 下载次数: 97)

2014-11-13 19:02 上传

点击文件名下载附件

onlycxb

108楼WinHttp.WinHttpRequest在接收数据过程中，会出现乱码。是利用了XMLHTTP避免了乱码问题。
以下代码利用BytesToBstr(.responseBody, "utf-8")进行了转码输出。

1. 
   
2. 
   
3. Sub 天气()
   
4. 'WinHttpRequest+htmlfile+.responsebody转码输出
   
5.     Dim W As New WinHttp.WinHttpRequest
   
6.     Dim js As New MSScriptControl.ScriptControl, arr
   
7.     Dim StrText As String, HTML As Object, tb, i%
   
8.     Dim MyCity As String
   
9.     Dim 更新日期 As String, 白天温度 As String, 夜间温度 As String, 天气 As String
   
10.    
    
11.     MyCity = "永安"             '输入地名
    
12.     Set HTML = CreateObject("htmlfile")
    
13.     HTML.DesignMode = "on"
    
14.     With W
    
15.         .Open "GET", "http://open.weather.sina.com.cn/api/location/getIndexSuggestion/" & MyCity, False
    
16.         .setRequestHeader "Referer", "http://weather.sina.com.cn/"
    
17.         .send
    
18.         MyCity = Split(Split(.responseText, """url"":""")(1), """")(0)
    
19.         .Open "GET", "http://weather.sina.com.cn/" & MyCity, False
    
20.         .send
    
21.         StrText = Replace(BytesToBstr(.responseBody, "utf-8"), vbCrLf, "")
    
22.     End With
    
23.     HTML.Write StrText
    
24.     Set tb = HTML.all.tags("p")
    
25. 
    
26.     For i = 0 To tb.Length - 1
    
27.         If tb(i).classname = "wt_fc_c0_i_day wt_fc_c0_i_today" Then
    
28.             更新日期 = tb(i - 1).innertext  '日期
    
29.             白天温度 = Trim(Split(Replace(tb(i + 3).innertext, "°C", ""), "/")(0))
    
30.             夜间温度 = Trim(Split(Replace(tb(i + 3).innertext, "°C", ""), "/")(1))
    
31.             天气 = Split(tb(i + 2).innertext, " ")(0) & "：" & tb(i + 1).ChildNodes(0).alt _
    
32.                & "，" & Split(tb(i + 2).innertext, " ")(1) & "：" & tb(i + 1).ChildNodes(2).alt _
    
33.                & "； " & tb(i + 4).innertext
    
34.         End If
    
35.     Next i
    
36.     Debug.Print 更新日期
    
37.     Debug.Print 白天温度
    
38.     Debug.Print 夜间温度
    
39.     Debug.Print 天气
    
40. End Sub
    
41. Function BytesToBstr(strBody, CodeBase)         '使用Adodb.Stream对象提取字符串
    
42.     Dim objStream
    
43.     On Error Resume Next
    
44.     Set objStream = CreateObject("Adodb.Stream")
    
45.     With objStream
    
46.         .Type = 1                               '二进制
    
47.         .Mode = 3                               '读写
    
48.         .Open
    
49.         .Write strBody                          '二进制数组写入Adodb.Stream对象内部
    
50.         .Position = 0                           '位置起始为0
    
51.         .Type = 2                               '字符串
    
52.         .Charset = CodeBase                     '数据的编码格式
    
53.         BytesToBstr = .ReadText                 '得到字符串
    
54.     End With
    
55.     objStream.Close
    
56.     Set objStream = Nothing
    
57.     If Err.Number <> 0 Then BytesToBstr = ""
    
58.     On Error GoTo 0
    
59. End Function
    

复制代码

onlycxb

1. Sub 董监高及相关人员持股变动明细 ()
   
2.     Dim xml As New MSXML2.XMLHTTP, url As String, St As String
   
3.     Dim js, dy, Pt As Integer, p As Integer, a, arr
   
4.     Application.ScreenUpdating = False
   
5.     Cells.Clear
   
6.     '   "http://data.eastmoney.com/executive/list.html"
   
7.     url = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GGMX&p=1&ps=1&js=(pc),(x)"
   
8.     With xml
   
9.         .Open "GET", url, False
   
10.         .send
    
11.         St = .responseText
    
12.         St = Split(St, ",")(0)
    
13.         Set js = CreateObject("MSScriptControl.ScriptControl")
    
14.         js.Language = "javascript"
    
15.         .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GGMX&ps=" & St & "&js=var%20TotsDJOt={pages:(pc),data:[(x)]}&rt=" & Rnd, False
    
16.         .send
    
17.         js.eval (Replace(Replace(.responseText, Chr(13), ""), Chr(10), ""))
    
18.         Set dy = js.eval("TotsDJOt.data")
    
19.         ReDim arr(1 To St, 1 To 16)
    
20.         i = 0
    
21.         For Each a In dy
    
22.             i = i + 1
    
23.             For j = 1 To 16
    
24.                 arr(i, j) = Split(a, ",")(j - 1)
    
25.             Next j
    
26.         Next a
    
27.     End With
    
28. 
    
29.     [a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
30.     Application.ScreenUpdating = True
    
31. End Sub

复制代码

onlycxb

网速慢，发重了。

VBA万岁

onlycxb 发表于 2014-11-10 20:21

此例可不用抓包，但速度不及楼上的快，代码如下：
Sub 董监高及相关人员持股变动明细2()
Dim xml As New MSXML2.XMLHTTP, url As String, St, St2 As String
Dim js, dy, ps, pc, pt As Integer, p As Integer, a
Application.ScreenUpdating = False
Cells.ClearContents
'Range("a1:o1") = Array("日期", "代码", "名称", "相关", "变动人", "变动股数", "成交均价", "变动金额(万)", "变动原因", "变动比例(%)", "变动后持股数", "持股种类", "董监高人员姓名", "职务", "变动人与董监高的关系")
Range("a1:o1") = Array("变动比例(%)", "董监高人员姓名", "代码", "变动人", "持股种类", "日期", "变动股数", "变动后持股数", "成交均价", "名称", "变动人与董监高的关系", "变动原因", "变动金额(万)", "职务", "相关")
url = "http://data.eastmoney.com/executive/list.html"
With xml
    .Open "GET", url, False
    .send
    'Debug.Print .responseText
    St = Split(Split(.responseText, "defjson:")(1), "," & vbNewLine & "            maketr:")(0)
    Set js = CreateObject("scriptcontrol")
    js.Language = "javascript"
    js.addcode ("首页数据= " & St)
    ps = js.Eval("首页数据.data.length")
    pc = UBound(Split(js.Eval("首页数据.data[0]"), ","))
    pt = js.Eval("首页数据.pages")
    MsgBox "总页数：" & pt & "，每页有" & ps & "条记录，每条记录有" & pc + 1 & "项"
        
    For p = 1 To 2 '2改为Pt可获得所有页码的数据
        .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GGMX&p=" & p & "&ps=" & ps & "&js=var {jsname}={pages:(pc),data:[(x)]}{param}", False
        .send
        'Debug.Print .responseText
        St2 = Split(Split(.responseText, "var {jsname}=")(1), "{param}")(0)
        js.addcode ("分页数据= " & St2)
        Set dy = js.Eval("分页数据.data")
        ReDim arr(1 To ps, 1 To pc + 1)
        i = 0
        For Each a In dy
            i = i + 1
            For j = 1 To pc + 1
                Cells((p - 1) * 50 + 1 + i, 1).Resize(, pc + 3) = Split(a, ",")
            Next j
        Next a
    Next p
End With
Range("L2:L" & ActiveSheet.UsedRange.Rows.Count).Delete Shift:=xlToLeft
Application.ScreenUpdating = True
End Sub

VBA万岁

VBA万岁 发表于 2014-11-11 16:37
此例可不用抓包，但速度不及楼上的快，代码如下：
Sub 董监高及相关人员持股变动明细2()
Dim xml As Ne ...

附件如下：
董监高及相关人员持股变动明细.zip (823.89 KB, 下载次数: 32)

2014-11-11 16:52 上传

点击文件名下载附件

VBA万岁

onlycxb 发表于 2014-11-10 20:21

以下代码由于在url 中直接用上总记录数ps可以获得所有记录，并且用数组直接取数，所以可大大提速至1、2秒钟：

Sub 董监高及相关人员持股变动明细3()
    Dim xml As New MSXML2.XMLHTTP, url As String, St As String
    Dim ps As Long, arr
    Application.ScreenUpdating = False
    Cells.ClearContents
    Range("a1:o1") = Array("变动比例(%)", "董监高人员姓名", "代码", "变动人", "持股种类", "日期", "变动股数", "变动后持股数", "成交均价", "名称", "变动人与董监高的关系", "变动原因", "变动金额(万)", "职务", "相关")
    url = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GGMX&p=1&ps=1&js=(pc),(x)"
    With xml
        .Open "GET", url, False
        .send
        ps = Split(.responseText, ",")(0)
        .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GGMX&ps=" & ps & "&js=var {jsname}={pages:(pc),data:[(x)]}{param}", False
        .send
        St = Split(Split(.responseText, "data:[")(1), "]}{param}")(0)
        arr = Split(St, Chr(34) & "," & Chr(34))
        For i = 0 To UBound(arr)
            Cells(i + 2, 1).Resize(, 16) = Split(arr(i), ",")
        Next i
    End With
    Range("L2:L" & ActiveSheet.UsedRange.Rows.Count).Delete Shift:=xlToLeft
    Application.ScreenUpdating = True
End Sub

onlycxb

分享:发现了一个全国省市区划数据，与大家分享

1. Sub test()
   
2.       ThisWorkbook.XmlImport URL:="http://wz.qiche100.cn/common/Area.xml?Time=" & Rnd, ImportMap:=Nothing, Overwrite:=True, Destination:=ActiveSheet.Range("a1")
   
3. End Sub

复制代码

VBA万岁

onlycxb 发表于 2014-11-12 20:38
分享:发现了一个全国省市区划数据，与大家分享

加上如下一句并将代码加入功能区以方便更新数据：
ActiveSheet.UsedRange.Delete

附件：
导入全国省市区划数据.zip (447.54 KB, 下载次数: 74)

2014-11-13 14:15 上传

点击文件名下载附件