ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: wcymiss

[原创] 不懂html也来学网抓(xmlhttp/winhttp+fiddler)

    [复制链接]

TA的精华主题

TA的得分主题

发表于 2014-10-24 12:42 | 显示全部楼层
本帖已被收录到知识树中,索引项:网页交互
VBA万岁 发表于 2014-10-24 11:18
onlycxb大侠,想请教你一个问题:
我想提取如下数据:

老师,我补齐了Referer,可还是报同样的错,不知为何?
我按你提供的地址下载安装了fiddler,抓包时界面好像同先前的一样host都省略了。
Sub 按钮1_单击()
    Dim Url, html
    Url = "http://www.pinble.com/Template/WebService1.asmx/PresentLis"

    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "POST", Url, False
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "Referer", "http://www.pinble.com/Template/WebService1.asmx/PresentLis"
        .send
        html.body.innerhtml = .responseText
        Cells(1, 1) = .responseText
        Set tb = html.all.tags("table")(4).Rows
        For i = 0 To tb.Length - 1
            For j = 1 To tb(i).Cells.Length - 1
                Cells(i + 1, j) = tb(i).Cells(j).innertext
            Next
        Next
    End With
End Sub

点评

setRequestHeader "Referer" 对xmlhttp对象是无效的。这份作业也不需要模拟referer。还有,你用了POST怎么没有sendData?我不明白你想做什么?  发表于 2014-10-24 13:23

TA的精华主题

TA的得分主题

发表于 2014-10-24 13:39 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 onlycxb 于 2014-10-24 14:22 编辑
VBA万岁 发表于 2014-10-24 11:18
onlycxb大侠,想请教你一个问题:
我想提取如下数据:
"Referer"
  1. Sub 各省福彩()
  2. Dim objhq As New WinHttp.WinHttpRequest
  3.     Dim STxt As String, Url As String, i As Integer, j As Integer
  4.     Dim Pages As Integer, Pstr As String, arr, brr, rng As Range
  5.     Cells.Clear
  6.     With objhq
  7.         .Open "POST", "http://www.pinble.com/Template/WebService1.asmx/PresentList", False
  8.         .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
  9.         .SetRequestHeader "Referer", "http://www.pinble.com/Lottery.htm" '121楼, .XMLHTTP中应用 .SetRequestHeader "Referer"是无效的。这里要采取HttpRequest方式
  10.         .Send "{type:'各省福彩'}"    '121楼,send 这里有发送的内容,一定要写上。
  11.         STxt = .ResponseText
  12.     End With
  13.     Debug.Print UTF8toChineseCharacters(STxt)                                                               '这里是Java编码格式,需要转换
  14. End Sub
  15. Function UTF8toChineseCharacters(szInput)
  16.     With CreateObject("MSScriptControl.ScriptControl")
  17.     .Language = "JavaScript"
  18.     .AddCode "function decode(str){return unescape(str.replace(/\u/g,'%u'));}"
  19.     UTF8toChineseCharacters = .Eval("decode('" & szInput & "')")
  20.     End With
  21. End Function
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-24 14:04 | 显示全部楼层
本帖最后由 wcymiss 于 2014-11-1 09:17 编辑

转码

1、有时我们获取到的数据,有很多乱码。
这是因为,Responsetext是按照UTF-8的编码格式来解析获取到的数据的,如果数据不是UTF-8编码的字符,就无法正确显示。
这时需要我们获取ResponseBody(这是源生态的没有经过任何编码的数据),然后自行对其进行解析。

比如,116楼例子的网址:http://20140507.ip138.com/ic.asp,因为字符编码是GB2312(charset=gb2312),我们直接显示ResponseText时,中文字符就显示为乱码。

转码1.png

转码最方便的就是利用adostream控件
转码的自定义函数参考11楼代码


2、"\uxxxx"类型的转码
17楼作业中的例子的responsetext包含了很多"\uxxxx"这样的字符,

转码2.png

这是一种unicode格式编码。我们需要对其还原本身的unicode字符。
jscript的unescape就是专门干这个的。

自定义转码函数:
  1. Function unescape(strTobecoded As String) As String
  2.     With CreateObject("msscriptcontrol.scriptcontrol")
  3.         .Language = "JavaScript"
  4.         unescape = .Eval("unescape('" & strTobecoded & "');")
  5.     End With
  6. End Function
复制代码
其实,jscript的eval可以直接转换"\uxxxx"
  1. Function JSEval(s As String) As String
  2.     With CreateObject("MSScriptControl.ScriptControl")
  3.         .Language = "javascript"
  4.         JSEval = .Eval(s)
  5.     End With
  6. End Function
复制代码
不管是用unescape还是直接Eval,都要注意文本的引号问题。这就好比你在excel的单元格内输入 ="excel" 不会出错,输入 =excel 就会提示出错一样。


3、HTML字符实体的转换
HTML字符实体就是诸如
  1.    "
复制代码
  1. 你///这里应该是半角分号,但我写半角分号发帖时会直接解析为汉字
复制代码
这样的字符串。

例子我暂时还没有找到。
先上转换的自定义函数,因为没找到网页测试,如果有bug请一定告诉我。
  1. Function EnCodeByHTML(strText As String)
  2.     With CreateObject("htmlfile")
  3.         .write strText
  4.         EnCodeByHTML = .body.innertext
  5.     End With
  6. End Function
复制代码
4、如果你手头还有其他转码类型,请一定告诉我。

================================================================
有坛友问ResponseBody和ResponseText的区别,这里补充说下:
1、ResponseBody是二进制的数据,是服务器传来的没有经过任何加工的数据。在网络中,文本一般都是以utf-8编码,所以xmlhttp/winhttp对象的ResponseText是按照utf-8编码把ResponseBody转换而成,也就是:ResponseText=ByteToStr(ResponseBody,"UTF-8")
至于问“为什么ByteToStr(ResponseText,"GB2312")没有结果”,原因是:一是参数类型不对,ByteToStr的第一参数是二进制数据的Byte数组类型,ResponseText是文本类型,系统提示出错;二是,即使进行了将文本转成二进制数据的转换(如下面代码里的b7=s这样的转换),这种转换也是按照某种编码进行的,这样的二进制已经进行过一次编码加工了,你再用ByteToStr就得不到原来的字符了。

2、对于StrConv和BytetoStr有什么区别,可以测试下面的代码:
  1. Sub Test()
  2.     Const s As String = "a我"
  3.     Dim b1() As Byte, b2() As Byte, b3() As Byte, b4() As Byte, b5() As Byte, b6() As Byte, b7() As Byte
  4.     b1 = StrToByte(s, "GB2312")
  5.     b2 = StrConv(s, vbFromUnicode) '系统默认
  6.     b3 = StrConv(s, vbFromUnicode, "2052") '内地中文
  7.     b4 = StrConv(s, vbFromUnicode, "1028") '台湾中文
  8.     b5 = StrToByte(s, "BIG5")
  9.     b6 = StrConv(s, vbUnicode)
  10.     b7 = s
  11.     Stop '查看本地窗口里以上几个变量
  12. End Sub
复制代码
有兴趣的还可以看看asc、ascw、chr、chrw这几个函数。

点评

scriptcontrol可以在64位下运行,需要做个包装  发表于 2016-9-28 20:39
回头我把我的解决方案给你吧,不过也不彻底,唉。  发表于 2014-10-24 22:53
还是老话,scriptcontrol在64位OFFICE跑不了。。。曾经很苦恼。现在我这里也还是不彻底。  发表于 2014-10-24 21:38

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-10-24 14:15 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
wcymiss 发表于 2014-10-21 11:15
目录:

一、前期准备:

俺喜欢这种条理清楚的贴子,收藏备学.

TA的精华主题

TA的得分主题

发表于 2014-10-24 14:17 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
wcymiss 发表于 2014-10-21 12:51
更多Fiddler的使用方法,敬请参考《Fiddler调试权威指南》一书。
电子书下载地址:http://pan.baidu.com/s ...

谢谢无私分享.

TA的精华主题

TA的得分主题

发表于 2014-10-24 14:22 | 显示全部楼层
本帖最后由 snailzlf 于 2014-10-24 14:23 编辑
wcymiss 发表于 2014-10-24 14:04
转码

1、有时我们获取到的数据,有很多乱码。

老师你好 请教下 如果网页上能看到数据,但是网页源码里面该数据没有显示,这样的数据怎么抓取
因为回复里发不了图片 我贴下我的帖子http://club.excelhome.net/thread-1160614-1-1.html  老师如果有时间帮忙看下 万分感谢

点评

教程里有说啊。您仔细看帖了吗?  发表于 2014-10-24 14:41

TA的精华主题

TA的得分主题

发表于 2014-10-24 14:29 | 显示全部楼层
wcymiss 发表于 2014-10-24 10:57
代理
如果服务器对同一IP有访问次数的限制,我们就要使用代理服务器了。

到代理了,http://club.excelhome.net/thread-1146118-1-1.html的我至今未得到答案。谢谢!

点评

关键要找到有用的代理。我就是没找到,所以代码里用了个失效的。还有,有些服务器会有防代理措施。  发表于 2014-10-24 14:48

TA的精华主题

TA的得分主题

发表于 2014-10-24 15:09 | 显示全部楼层
snailzlf 发表于 2014-10-24 14:22
老师你好 请教下 如果网页上能看到数据,但是网页源码里面该数据没有显示,这样的数据怎么抓取
因为回复 ...

可能是我浏览的比价快 没看到 现在马上去看  谢谢老师

TA的精华主题

TA的得分主题

发表于 2014-10-24 15:26 | 显示全部楼层
onlycxb 发表于 2014-10-24 13:39

多谢onlycxb大侠,经你的指点,增加了如下代码,终于通过:
.Send "{type:'各省福彩'}

另,提取七星彩数据,在你代码的基础上,用另一种方法提取如下:
Sub 江苏七星彩2()
Dim html
Dim objhq As New MSXML2.xmlhttp
Dim STxt As String, Url As String, i As Integer, j As Integer
Dim Pages As Integer, Pstr As String, arr, brr, rng As Range
Cells.Clear
With objhq
    .Open "POST", "http://www.pinble.com/Template/WebService1.asmx/Present3DList", False
    .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .SetRequestHeader "Referer", "http://www.pinble.com/Lottery.htm"
    .Send "{pageindex:'1',lottory:'TC7XCData_jiangS',pl3:'',name:'江苏七星彩',isgp: '0'}"
    STxt = .ResponseText
End With
STxt = UTF8toChineseCharacters(STxt)                                                           'J3编码
Pages = Split(Split(Split(STxt, "分页")(1), "页")(0), "/")(1)

'循环各页取数,下面以取2页为例 ,实际总页数Pages
Set html = CreateObject("htmlfile")
For p = 1 To 2
    With objhq
        .Open "POST", "http://www.pinble.com/Template/WebService1.asmx/Present3DList", False
        .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
        .SetRequestHeader "Referer", "http://www.pinble.com/Lottery.htm"
        .Send "{pageindex:'" & p & "',lottory:'TC7XCData_jiangS',pl3:'',name:'江苏七星彩',isgp: '0'}"
        html.body.innerhtml = UTF8toChineseCharacters(.ResponseText)

        Set tb = html.all.tags("table")(2).Rows
        For i = 0 To tb.Length - 1
            For j = 0 To tb(i).Cells.Length - 1
                Cells((p - 1) * 41 + i + 1, j + 1) = tb(i).Cells(j).innertext
            Next j
        Next i

   End With
Next p
Columns("A:A").NumberFormatLocal = "yyyy-m-d"
Columns("B:C").NumberFormatLocal = "@"
End Sub

Function UTF8toChineseCharacters(szInput)
    With CreateObject("MSScriptControl.ScriptControl")
    .Language = "JavaScript"
    .AddCode "function decode(str){return unescape(str.replace(/\u/g,'%u'));}"
    UTF8toChineseCharacters = .Eval("decode('" & szInput & "')")
    End With
End Function

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-10-24 15:40 | 显示全部楼层
VBA万岁 发表于 2014-10-24 15:26
多谢onlycxb大侠,经你的指点,增加了如下代码,终于通过:
.Send "{type:'各省福彩'}

附件如下:
江苏七星彩.zip (1.94 MB, 下载次数: 466)

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-22 04:14 , Processed in 0.050276 second(s), 7 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表