单击“提交”后，VBA Excel将提取新的网页数据

Question

我正在尝试从一个通过API编号提供油井数据的网站上获取一些信息（API是美国每口井的唯一编号）

网站： http ： //sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellapi1

API范例：1708300502

问题是，当我进入第二页时，IE.document.getElementsByTagName（“ body”）（0）.innerText仍从初始页返回数据。 如何获取更新的页面数据？

最终目标是进入第二页，通过IE.document.getElementsByTagName（“ a”）（0）单击“ 30570”。单击，然后阅读最后的第三页。 我只是不知道如何阅读更新的页面:(

Option Explicit

Sub sonris_WellData()
   Dim IE As InternetExplorer
   Set IE = CreateObject("InternetExplorer.Application")
   IE.Visible = True

   Dim i As Integer

   'Open SONRIS website
   Application.StatusBar = "Opening Website"
   IE.navigate "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellapi1"
   Do While IE.readyState <> 4: DoEvents: Loop
   Application.Wait Now() + TimeValue("00:00:01")
   Application.StatusBar = False

   IE.document.forms(0).p_apinum.Value = "1708300502" 'plug-in API
   IE.document.forms(0).submit

   ' Wait until the next page opens
   Application.StatusBar = "Opening Website"
   Do While IE.readyState <> 4: DoEvents: Loop
   Application.Wait Now() + TimeValue("00:00:01")
   Application.StatusBar = False

   ' Read the page - this is where the issue occurs, MsgBox keeps returning text from the very 1st page
   MsgBox IE.document.getElementsByTagName("body")(0).innerText

   IE.Quit
End Sub

Answer 1

这似乎正在工作。 而不是DoEvents使用WinAPI Sleep函数。 表单提交后，我还添加了对Sleep函数的调用。

通常，我们经常看到某些javascript / etc等动态服务的网站，在这些情况下，浏览器可能看起来是READYSTATE_COMPLETE或Busy但是页面尚未呈现“新”结果。

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub sonris_WellData()
   Dim IE As Object 'InternetExplorer
   Set IE = CreateObject("InternetExplorer.Application")
   IE.Visible = True

   Dim i As Integer

   'Open SONRIS website
   Application.StatusBar = "Opening Website"
   IE.navigate "http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellapi1"
   Do While IE.readyState <> 4
       Sleep 1000
   Loop

   Application.StatusBar = False

   IE.document.forms(0).p_apinum.Value = "1708300502" 'plug-in API
   IE.document.forms(0).submit

   Sleep 1000

   ' Wait until the next page opens
   Application.StatusBar = "Opening Website"
   Do While IE.readyState <> 4
    Sleep 1000
   Loop

   Application.StatusBar = False

   ' Read the page - this is where the issue occurs, MsgBox keeps returning text from the very 1st page
   MsgBox IE.document.getElementsByTagName("body")(0).innerText

   IE.Quit
End Sub

您可以在.submit之后.submit稍长的Sleep进行.submit 。

另外，我注意到提交后URL会更改，因此您也可以尝试将第二个等待循环更改为：

Do While IE.LocationURL ="http://sonlite.dnr.state.la.us/sundown/cart_prod/cart_con_wellapi1"
    Sleep 1000
Loop

这应该使Excel.Application等待URL更改。

另外，使用XMLHTTPRequest可能会有更好的运气（SO和互联网上的其他地方有很多这样的示例）。 这样，您就可以像浏览器一样发送请求，而无需实际使用Web浏览器。 然后，您可以简单地将返回文本解析为HTML或XML。 我将为此使用Microsoft XML v6.0库参考。

Answer 2

POST请求：

①输入Well API编号

我检查了您选择的网页。 我使用提琴手检查了网络流量，并注意到当您提交API编号时，初始请求是由POST请求处理的。

---

②POST请求：

POST正文具有以下参数：

p_apinum是键，而关联的值是原始的Well API号。

使用此信息，我直接制定了POST请求，从而避免了您的第一个登录页面。

---

③按下超链接：

接下来，我注意到您要按下的元素：

查看关联的HTML，它具有关联的相对超链接：

我使用一个辅助函数来解析页面HTML以获得此相对链接并构造绝对路径： GetNextURL(page.body.innerHTML) 。

---

④提出新要求：

我重新使用HTTPRequest函数GetPage发送第二个请求，该请求的主体为空，并从通过以下page.getElementsByTagName("table")返回的HTML文档中获取所有表： page.getElementsByTagName("table") 。

---

⑤将表格写入Excel工作表：

我使用辅助函数AddHeaders循环页面上的所有表以写出表头，并使用WriteTables将当前表写到表中。

---

页面内容示例：

---

示例代码输出：

---

VBA：

Option Explicit
Public Sub GetWellInfo()
    Dim ws As Worksheet, page As HTMLDocument, targetTable As HTMLTable, apiNumbers(), currNumber As Long
    Const PARAM1 As String = "p_apinum"
    Const BASESTRING As String = "http://sonlite.dnr.state.la.us/sundown/cart_prod/"
    apiNumbers = Array(1708300502, 1708300503)

    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        .Cells.ClearContents
        For currNumber = LBound(apiNumbers) To UBound(apiNumbers)
            Set page = GetPage(BASESTRING & "cart_con_wellapi2", apiNumbers(currNumber), PARAM1)
            Set page = GetPage(BASESTRING & GetNextURL(page.body.innerHTML))
            Dim allTables As Object
            Set allTables = page.getElementsByTagName("table")

            For Each targetTable In allTables
                AddHeaders targetTable, GetLastRow(ws, 1) + 2, ws
                WriteTables targetTable, GetLastRow(ws, 1), ws
            Next targetTable

        Next currNumber
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetPage(ByVal url As String, Optional ByVal apiNumber As Long, Optional ByVal paramN As String = vbNullString) As HTMLDocument
    Dim objHTTP As Object, html As New HTMLDocument

    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim sBody As String
    If Not paramN = vbNullString Then sBody = paramN & "=" & apiNumber
    With objHTTP
        .SetTimeouts 10000, 10000, 10000, 10000
        .Open "POST", url, False
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
        On Error Resume Next
        .send (sBody)
        If Err.Number = 0 Then
            If .Status = "200" Then
                html.body.innerHTML = .responseText
                Set GetPage = html
            Else
                Debug.Print "HTTP " & .Status & " " & .statusText
                Exit Function
            End If
        Else
            Debug.Print "Error " & Err.Number & " " & Err.Source & " " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
    End With

End Function

Public Function GetNextURL(ByVal inputString As String)
    GetNextURL = Replace$(Replace$(Split(Split(inputString, "href=")(1), ">")(0), Chr$(34), vbNullString), "about:", vbNullString)
End Function

Public Sub AddHeaders(ByVal hTable As Object, ByVal startRow As Long, ByVal ws As Worksheet)
    Dim headers As Object, header As Object, columnCounter As Long
    Set headers = hTable.getElementsByTagName("th")
    For Each header In headers
        columnCounter = columnCounter + 1
        ws.Cells(startRow, columnCounter) = header.innerText
    Next header
End Sub

Public Sub WriteTables(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByRef ws As Worksheet)
    If ws Is Nothing Then Set ws = ActiveSheet

    Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
    r = startRow
    With ActiveSheet
        Set tRow = hTable.getElementsByTagName("tr")
        For Each tr In tRow
            Set tCell = tr.getElementsByTagName("td")
            For Each td In tCell
                .Cells(r, c).Value = td.innerText
                c = c + 1
            Next td
            r = r + 1:  c = 1
        Next tr
    End With
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

---

参考文献：

VBE>工具>引用> HTML对象库。