读取网页源代码

Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")

xmlHTTP1.Open "get", "https://chart.cp.360.cn/zst/getchartdata?lotId=255401&chartType=x5zh&spanType=0&span=300&r=0.4348563654548525#roll_132", True

xmlHTTP1.send

While xmlHTTP1.readyState <> 4

DoEvents

Wend

wstr1 = xmlHTTP1.responseText

Set xmlHTTP1 = Nothing

有时无法刷新，咋办？

如果你用的是Msxml2.XMLHTTP（Microsoft.XMLHTTP），可以换成Msxml2.ServerXMLHTTP试试。另外也可以试试每次请求完都销毁对象，下次请求前重新创建对象。

===========================

下面内容来源于 http://www./archives/175

要实现网站数据的采集，首先要了解HTTP协议。

当我们在浏览器中输入网址，按下回车时，客户端会发送一个请求到服务器，服务器根据请求的内容返回数据到客户端，浏览器显示返回的结果。

当用编程的方法获取网站数据时，实际上就是模拟了以上的过程，客户端发送请求→服务器响应发回结果。

然后通过各种方式处理获得的结果，提取想要的数据。

本文介绍用WinHttpRequest对象进行网站数据采集的方法。

以下代码是最基础的获取网站数据的vba代码：

Sub QQ1722187970()

    Dim oHtml As Object

    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim sUrl As String

    sUrl = "https://blog.csdn.net/tylm22733367/article/details/52596990"

    With oHtml

        .Open "GET", sUrl, False

        .send

        Debug.Print .ResponseText

    End With

    Set oHtml = Nothing

End Sub

由于不同的网站有不同的编码字符集，如果不是UTF-8或者Unicode编码字符集，用ResponseText返回的字符在VBA中会乱码。

为此，可以使用如下的代码实现通用的获取网站数据：

Sub QQ1722187970()

    Dim oHtml As Object

    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim sUrl As String

    '指定要抓取的网站

    sUrl = "https://blog.csdn.net/tylm22733367/article/details/52596990"

    Dim sCharset As String

    '指定要抓取的网站的字符编码

    sCharset = "utf-8"

    With oHtml

        .Open "GET", sUrl, False

        .Send

        '获取返回的字节数组

        bResult = .ResponseBody

        '按照指定的字符编码显示

        sResult = Byte2String(bResult, sCharset)

        Debug.Print sResult

    End With

    Set oHtml = Nothing

End Sub

Function Byte2String(bContent, ByVal sCharset As String)

    Const adTypeBinary = 1

    Const adTypeText = 2

    Const adModeRead = 1

    Const adModeWrite = 2

    Const adModeReadWrite = 3

    Dim oStream As Object

    '创建流对象

    Set oStream = CreateObject("ADODB.Stream")

    With oStream

        '打开流

        .Open

        '设置为字节模式

        .Type = adTypeBinary

        '写入字节

        .Write bContent

        '将位置定位在第一个字节

        .Position = 0

        '设置为文本模式

        .Type = adTypeText

        '设置编码的字符集

        .Charset = sCharset

        '读取编码后的文本

         Byte2String = .ReadText

        '关闭流对象

        .Close

    End With

End Function

'提取网页表格的代码

Sub HtmlTable(ByVal sHtml As String)

    '网页html文档对象

    Dim oHtmlDom As Object

    '网页表格对象

    Dim oTable As Object

    '网页表格行对象

    Dim oRows As Object

    '网页表格单元格对象

    Dim oCells As Object

    '抓取的数据存放的excel表格对象

    Dim oWK As Worksheet

    Set oWK = Sheet1

    iRow = oWK.Range("a65536").End(xlUp).Row + 1

    Set oHtmlDom = CreateObject("htmlfile")

    With oHtmlDom

        .Body.innerHTML = sHtml

        Set oTable = .getElementsByTagName("table")(0)

        'Set obj = getElementById("id")

        With oTable

            Set oRows = .Rows

            For i = 1 To oRows.Length - 1

                Set oCells = oRows(i).Cells

                For j = 0 To oCells.Length - 1

                    oWK.Cells(iRow, j + 1) = oCells(j).innertext

                Next j

                iRow = iRow + 1

            Next i

        End With

    End With

    Set oHtmlDom = Nothing

    Set oTable = Nothing

    Set oRows = Nothing

    Set oCells = Nothing

End Sub

以上介绍的是最基本的GET网络请求的数据，如果要抓取POST请求的数据，可以使用如下的通用代码：

Sub QQ1722187970()

    Dim oHtml As Object

    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim sUrl As String

    '指定要抓取的网站

    sUrl = "http://kw.beijing.gov.cn/module/web/jpage/dataproxy.jsp?startrecord=1&endrecord=120&perpage=40"

    Dim sPostText As String

    sPostText = "col=1&appid=1&webid=1&path=%2F&columnid=149&sourceContentType=3&unitid=2793&webname=%E5%8C%97%E4%BA%AC%E5%B8%82%E7%A7%91%E5%AD%A6%E6%8A%80%E6%9C%AF%E5%A7%94%E5%91%98%E4%BC%9A&permissiontype=0"

    Dim sCharset As String

    '指定要抓取的网站的字符编码

    sCharset = "utf-8"

    With oHtml

        .Open "POST", sUrl, False

        'POST方法一定要带Content-Type请求头

        .setRequestheader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"

        .Send sPostText

        '获取返回的字节数组

        bResult = .ResponseBody

        '按照指定的字符编码显示

        sResult = Byte2String(bResult, sCharset)

        Debug.Print sResult

    End With

    Set oHtml = Nothing

End Sub

Function Byte2String(bContent, ByVal sCharset As String)

    Const adTypeBinary = 1

    Const adTypeText = 2

    Const adModeRead = 1

    Const adModeWrite = 2

    Const adModeReadWrite = 3

    Dim oStream As Object

    '创建流对象

    Set oStream = CreateObject("ADODB.Stream")

    With oStream

        '打开流

        .Open

        '设置为字节模式

        .Type = adTypeBinary

        '写入字节

        .Write bContent

        '将位置定位在第一个字节

        .Position = 0

        '设置为文本模式

        .Type = adTypeText

        '设置编码的字符集

        .Charset = sCharset

        '读取编码后的文本

         Byte2String = .ReadText

        '关闭流对象

        .Close

    End With

End Function

'提取网页表格的代码

Sub HtmlTable(ByVal sHtml As String)

    '网页html文档对象

    Dim oHtmlDom As Object

    '网页表格对象

    Dim oTable As Object

    '网页表格行对象

    Dim oRows As Object

    '网页表格单元格对象

    Dim oCells As Object

    '抓取的数据存放的excel表格对象

    Dim oWK As Worksheet

    Set oWK = Sheet1

    iRow = oWK.Range("a65536").End(xlUp).Row + 1

    Set oHtmlDom = CreateObject("htmlfile")

    With oHtmlDom

        .Body.innerHTML = sHtml

        Set oTable = .getElementsByTagName("table")(0)

        'Set obj = getElementById("id")

        With oTable

            Set oRows = .Rows

            For i = 1 To oRows.Length - 1

                Set oCells = oRows(i).Cells

                For j = 0 To oCells.Length - 1

                    oWK.Cells(iRow, j + 1) = oCells(j).innertext

                Next j

                iRow = iRow + 1

            Next i

        End With

    End With

    Set oHtmlDom = Nothing

    Set oTable = Nothing

    Set oRows = Nothing

    Set oCells = Nothing

End Sub