vba-网络抓取（get，post）

1.网络抓取有很多种方法，处理也有很多种方法，以下提供一些代码，仅供参考

（1）GET获取数据

Option Explicit
'以快递一百查询快递单号为例
'用fiddler 来查看自己想要的链接等信息
'GET请求获取数据
Public Sub testkuaidi()
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP") '创建XML对象
    xmlhttp.Open "GET", "http://www.kuaidi100.com/query?type=zhongtong&postid=217236429995", False  '用GET 发送请求
    
    xmlhttp.Send
    '等待响应
    Do While xmlhttp.readyState <> 4
        DoEvents
    Loop
    '将结果打印出来
    Debug.Print xmlhttp.responsetext
End Sub
'防盗链处理
Public Sub testkuaidi2()
    Dim winhttp As Object
    Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    winhttp.Open "GET", "http://www.kuaidi100.com/query?type=zhongtong&postid=217236429995", False  '&temp=0.978924173706677
    '如果网站有防盗处理（即必须要从该网站进入）则可以进行防盗链处理，也很简单，在请求和发送之间设置头信息
    winhttp.setrequestheader "Referer", "http://www.kuaidi100.com/" '设置请求的头信息
    winhttp.Send
    
    Debug.Print winhttp.responsetext
End Sub

（2）数据处理（json）

Option Explicit
'json 解析
Sub textjson()
    Const strjson As String = "[""甲"",""乙"",""丙""]"
    Dim objjson As Object
    Dim cell
    With CreateObject("msscriptcontrol.scriptcontrol")
        .Language = "JavaScript"
        .addcode "var mydata=" & strjson
        Set objjson = .codeobject
        
    End With
    Stop
    For Each cell In objjson.mydata
        Debug.Print cell
    Next
End Sub
Public Function testjson2(strjson As String)
    Dim objjson
    With CreateObject("msscriptcontrol.scriptcontrol")
    .Language = "JavaScript"
        .addcode "var mydata=" & strjson
        Set objjson = .codeobject
    End With
    Set testjson2 = objjson
End Function

Public Function test3()
    Dim objjson As Object
    Set objjson = testjson2("[{""name"":""er"",""age"":18},{""name"":""ur"",""age"":45}]")
    Dim objitem As Object
    For Each objitem In objjson.mydata
        Debug.Print CallByName(objitem, "name", VbGet)
        Debug.Print CallByName(objitem, "age", VbGet)
        Debug.Print
    Next
    
    
End Function

(3)POST方法获取数据

'有道翻译
Option Explicit
'用post方法来获取信息
Public Sub translate(str As String) '输入字符则可以翻译
    If str = "" Then Exit Sub
    Dim objxml As Object
    Set objxml = CreateObject("MSXML2.XmlHttp")
    objxml.Open "POST", "http://fanyi.youdao.com/translate", False
    objxml.setrequestheader "Content-Type", "application/x-www-from-urlencode;charset=UTF-8"
    objxml.Send "i=" & str & "&doctype=json" '指定
    Do While objxml.readyState <> 4
        DoEvents
    Loop
    Dim strresponse As String
    strresponse = objxml.responsetext
    Debug.Print strresponse
       Debug.Print Split(Split(strresponse, "tgt"":""")(1), """")(0)
End Sub
Public Sub test()
    Dim objxml As Object
    Set objxml = CreateObject("MSXML2.XMLHTTP")
    objxml.Open "POST", "http://fanyi.youdao.com/translate", False
    objxml.setrequestheader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
    objxml.Send "i=hello&doctype=json"
    Do While objxml.readyState <> 4
        DoEvents
    Loop
    Dim strresponse As String
    strresponse = objxml.responsetext
    Debug.Print strresponse
   Debug.Print Split(Split(strresponse, "tgt"":""")(1), """")(0)
End Sub