网页抓取分享

renahu

bluexuemei 发表于 2014-11-1 13:32
第5个函数就是在第一个函数的基础上去掉%而已。其实总共就两个JS函数escape 和unescape的运用

第五个函数去掉 % 换成 \了？

renahu

谁知道程序代码怎么发，才能左边带序号，而且最下面还有个“复制代码”？看着很漂亮啊

onlycxb

bluexuemei 发表于 2014-11-1 13:32
第5个函数就是在第一个函数的基础上去掉%而已。其实总共就两个JS函数escape 和unescape的运用

说的没错。因为网上找到的。所以一并拿出来。

onlycxb

天气网定制温度
'网址防盗,json数据

1. Sub 天气2()
   
2.     Dim dy1, dy2,t$
   
3.        With CreateObject("WinHttp.WinHttpRequest.5.1")
   
4.         .Open "GET", "http://d1.weather.com.cn/dingzhi/101281801.html?_=1415160187867", False
   
5.         .SetRequestHeader "Referer", "http://www.weather.com.cn/weather1d/101281801.shtml"
   
6.         .send
   
7.         t = .ResponseText
   
8.     End With
   
9.     With CreateObject("MSScriptControl.ScriptControl")
   
10.         .Language = "javascript"
    
11.         .AddCode (t)
    
12.         Set dy1 = .Eval("alarmDZ101281801.w[0]")
    
13.         Set dy2 = .Eval("cityDZ101281801.weatherinfo")
    
14.         Debug.Print dy1.w8
    
15.         Debug.Print dy2.tempn
    
16.         Debug.Print dy2.temp
    
17.         Debug.Print dy2.weather
    
18.     End With
    
19. End Sub
    

复制代码

responsetext:
var cityDZ101281801 ={"weatherinfo":{"city":"101281801","cityname":"阳江","temp":"22℃","tempn":"27℃","weather":"多云转阴","weathercode":"n1","weathercoden":"d2"}};

var alarmDZ101281801 ={"w":[{"w1":"广东省","w2":"阳江","w3":"阳江","w4":"gd09","w5":"森林火险","w6":"03","w7":"黄色","w8":"2014-10-07 09:55:00","w9":"森林火险等级为三级。中度危险，林内可燃物较易燃烧，森林火灾较易发生","w10":"20141007095500森林火险黄色","w11":"0662J"}]}
立即窗口:
2014-10-07 09:55:00
27℃
22℃
多云转阴

tbjx138

onlycxb大神您好：我发了个求助网抓的帖子，能否帮忙看下，谢谢了！！网址附上：http://club.excelhome.net/forum. ... p;page=1#pid7931400，我看了您的网抓的案例，也很想学习网抓，以后还请多指导！！

onlycxb

再玩天气

1. Sub 天气()
   
2.     Dim xml As New MSXML2.XMLHTTP
   
3.     Dim js As New MSScriptControl.ScriptControl, dy1, dy2
   
4.     Dim StrText As String, HTML As Object, tb, i
   
5.     Dim 更新日期 As String, 白天温度 As String, 夜间温度 As String, arr
   
6.     Dim 天气 As String
   
7.     Dim r As Long                                                    '温度统计表最后一行
   
8.     Set HTML = CreateObject("htmlfile")
   
9.     HTML.DesignMode = "on"
   
10.     With xml
    
11.         .Open "GET", "http://weather.sina.com.cn/yangjiang", False
    
12.         .send
    
13.         StrText = Replace(.ResponseText, vbCrLf, "")
    
14.     End With
    
15.     HTML.write StrText
    
16.     Set tb = HTML.all.tags("p")
    
17. 
    
18.     For i = 0 To tb.Length - 1
    
19.         If tb(i).classname = "wt_fc_c0_i_day wt_fc_c0_i_today" Then
    
20.             更新日期 = tb(i - 1).innertext  '日期
    
21.             白天温度 = Split(Replace(tb(i + 3).innertext, "°C", ""), "/")(0)
    
22.             夜间温度 = Split(Replace(tb(i + 3).innertext, "°C", ""), "/")(1)
    
23.             天气 = Split(tb(i + 2).innertext, " ")(0) & "：" & tb(i + 1).ChildNodes(0).alt _
    
24.                & "，" & Split(tb(i + 2).innertext, " ")(1) & "：" & tb(i + 1).ChildNodes(2).alt _
    
25.                & "； " & tb(i + 4).innertext
    
26.         End If
    
27.     Next i
    
28. End Sub

复制代码

VBA万岁

onlycxb 发表于 2014-11-7 08:12
再玩天气

虽有很多方法可以实现该网抓，重要的是，onlycxb大侠的代码让我学会了另一种htmlfile网抓方法，多谢！

onlycxb

VBA万岁 发表于 2014-11-7 09:55
虽有很多方法可以实现该网抓，重要的是，onlycxb大侠的代码让我学会了另一种htmlfile网抓方法，多谢！

1. Option Explicit
   
2. 
   
3. Sub 天气()
   
4.     Dim W As New WinHttp.WinHttpRequest, X As New MSXML2.XMLHTTP
   
5.     Dim js As New MSScriptControl.ScriptControl, arr
   
6.     Dim StrText As String, HTML As Object, tb, i%
   
7.     Dim MyCity As String
   
8.     Dim 更新日期 As String, 白天温度 As String, 夜间温度 As String, 天气 As String
   
9.     MyCity = "永康"             '输入地名
   
10.     Set HTML = CreateObject("htmlfile")
    
11.     HTML.DesignMode = "on"
    
12.     With W
    
13.         .Open "GET", "http://open.weather.sina.com.cn/api/location/getIndexSuggestion/" & MyCity, False
    
14.         .setRequestHeader "Referer", "http://weather.sina.com.cn/"
    
15.         .send
    
16.         MyCity = Split(Split(.responseText, """url"":""")(1), """")(0)
    
17.     End With
    
18.     With X
    
19.         .Open "GET", "http://weather.sina.com.cn/" & Mycity, False
    
20.         .send
    
21.         StrText = Replace(.responseText, 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. 
    

复制代码

onlycxb

VBA万岁 发表于 2014-11-7 12:42
自定义函数PinYin详见附件：

非常全的拼音函数，强悍！

VBA万岁

onlycxb 发表于 2014-11-7 10:49

多谢onlycxb大侠分享！
分别用网抓及自定义函数获得城市拼音码，并取数如下：

Option Explicit

Sub 天气3()
    Dim W As New WinHttp.WinHttpRequest, X As New MSXML2.XMLHTTP
    Dim js As New MSScriptControl.ScriptControl, arr
    Dim StrText As String, HTML As Object, tb, i%
    Dim MyCity, eMyCity As String
    Dim 更新日期 As String, 白天温度 As String, 夜间温度 As String, 天气 As String
    MyCity = InputBox("请输入城市名", "城市", "北京")
    Set HTML = CreateObject("htmlfile")
    HTML.DesignMode = "on"
    With W
        .Open "GET", "http://open.weather.sina.com.cn/api/location/getIndexSuggestion/" & MyCity, False
        .setRequestHeader "Referer", "http://weather.sina.com.cn/"
        .send
        eMyCity = Split(Split(.responseText, """url"":""")(1), """")(0)
    End With
    With X
        .Open "GET", "http://weather.sina.com.cn/" & eMyCity, False
        .send
        StrText = Replace(.responseText, vbCrLf, "")
    End With
    HTML.Write StrText
    Set tb = HTML.all.tags("p")

    For i = 0 To tb.Length - 1
        If tb(i).classname = "wt_fc_c0_i_day wt_fc_c0_i_today" Then
            更新日期 = tb(i - 1).innertext
            白天温度 = Split(tb(i + 3).innertext, "/")(0)
            夜间温度 = Split(tb(i + 3).innertext, "/")(1)
            天气 = Split(tb(i + 2).innertext, " ")(0) & "：" & tb(i + 1).ChildNodes(0).alt _
               & "，" & Split(tb(i + 2).innertext, " ")(1) & "：" & tb(i + 1).ChildNodes(2).alt _
               & "； " & tb(i + 4).innertext
        End If
    Next i
    MsgBox MyCity & 更新日期 & "天气情况：" & vbCrLf & "白天温度：" & 白天温度 & vbNewLine & "夜间温度：" & 夜间温度 & Chr(10) & "天气：" & 天气, , "城市天气预报"
End Sub

Sub 天气4()
    Dim X As New MSXML2.XMLHTTP
    Dim js As New MSScriptControl.ScriptControl, arr
    Dim StrText As String, HTML As Object, tb, i%
    Dim MyCity As String
    Dim 更新日期 As String, 白天温度 As String, 夜间温度 As String, 天气 As String
    MyCity = InputBox("请输入城市名", "城市", "北京")
    Set HTML = CreateObject("htmlfile")
    HTML.DesignMode = "on"
    With X
        .Open "GET", "http://weather.sina.com.cn/" & PinYin(MyCity, "", 2), False
        .send
        StrText = Replace(.responseText, vbCrLf, "")
    End With
    HTML.Write StrText
    Set tb = HTML.all.tags("p")

    For i = 0 To tb.Length - 1
        If tb(i).classname = "wt_fc_c0_i_day wt_fc_c0_i_today" Then
            更新日期 = tb(i - 1).innertext
            白天温度 = Split(tb(i + 3).innertext, "/")(0)
            夜间温度 = Split(tb(i + 3).innertext, "/")(1)
            天气 = Split(tb(i + 2).innertext, " ")(0) & "：" & tb(i + 1).ChildNodes(0).alt _
               & "，" & Split(tb(i + 2).innertext, " ")(1) & "：" & tb(i + 1).ChildNodes(2).alt _
               & "； " & tb(i + 4).innertext
        End If
    Next i
    MsgBox MyCity & 更新日期 & "天气情况：" & vbCrLf & "白天温度：" & 白天温度 & vbNewLine & "夜间温度：" & 夜间温度 & Chr(10) & "天气：" & 天气, , "城市天气预报"
End Sub