HTML Коллекция элементов заполнена с предыдущей веб-страницы, а не с перенаправленной веб-страницы VBA - PullRequest
Новая
       8

HTML Коллекция элементов заполнена с предыдущей веб-страницы, а не с перенаправленной веб-страницы VBA

1 голос
/ 30 марта 2020

Приведенный ниже код перемещается на веб-страницу, заполняет поля поиска запросами и отправляет их на страницу результатов. Однако последняя коллекция элементов в сценарии tdtags, которая определяется после перенаправления, получает данные с исходной страницы поиска, а не со страницы результатов. В настоящее время у меня есть время ie .busy oop и временная задержка в сценарии, ни одна из которых не работает. Я также пытался дождаться, пока элемент, присутствующий только на странице результатов, станет доступным в html, но это также не работает. 

Dim twb As Workbook
Dim ie As Object

Set twb = ThisWorkbook
twb.Activate

Set ie = CreateObject("internetexplorer.application")
'church = Sheets("Control").Range("A2").Value
'minister = Sheets("Control").Range("A4").Value
location = "London" 'Sheets("Control").Range("A6").Value
'denomination = Sheets("Control").Range("A8").Value

With ie
.navigate "http://www.ukchurch.org/index.php"
.Visible = True
Do While .Busy Or .ReadyState <> 4
DoEvents
Loop
End With
Application.Wait (Now + TimeValue("00:00:02"))

Set intags = ie.document.getelementsbytagname("input")

For Each intag In intags
If intag.getattribute("name") = "name" Then
If church <> "" Then
intag.Value = church
End If
ElseIf intag.getattribute("name") = "minister" Then
If minister <> "" Then
intag.Value = minister
End If
ElseIf intag.getattribute("name") = "location" Then
If location <> "" Then
intag.Value = location
End If
Else
End If
Next intag

Set dropopt = ie.document.getelementsbytagname("select")
For Each dropo In dropopt
If dropo.classname = "DenominationDropDown" Then
Set opttags = dropo.getelementsbytagname("option")
For Each opt In opttags
If opt.innertext = denomination Then
opt.Selected = True
End If
Next opt
End If
Next dropo

On Error Resume Next
For Each intag In intags
If intag.getattribute("src") = "images/ukchurch/button-go.jpg" Then
intag.Click
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
Application.Wait (Now + TimeValue("00:00:03"))
Exit For
End If
Next intag

Application.Wait (Now + TimeValue("00:00:03"))

Set tdtags = ie.document.getelementsbytagname("td")
For Each td In tdtags
If td.classname = "pText" Then
Debug.Print td.innertext
Debug.Print ie.locationURL
pagecount = Right(td.innertext, InStr(td.innertext, ":"))
End If
Next td
Debug.Print pagecount

End Sub

Любой диагноз будет признателен.

1 Ответ

1 голос
/ 30 марта 2020

Автоматизация IE - это боль, поэтому избегайте ее.

Следующая функция напрямую запрашивает страницу результатов. 

Public Function GetSearchResult(Optional ByVal ResultPage As Integer = 0, Optional ByVal ChurchName As String = "", Optional ByVal Minister As String = "", Optional ByVal ChurchLocation As String = "", Optional ByVal Denomination As String = "") As Object
Dim Request As Object: Set Request = CreateObject("MSXML2.serverXMLHTTP")
Dim Result As Object: Set Result = CreateObject("htmlfile")

Request.Open "POST", "http://www.ukchurch.org/searchresults1.php", False
Request.setRequestHeader "content-type", "application/x-www-form-urlencoded"
Request.send IIf(ResultPage = 0, "", "page=" & ResultPage & "&") & "name=" & ChurchName & "&minister=" & Minister & "&location=" & ChurchLocation & "&denomination=" & Denomination

Result.body.innerHTML = Request.responseText

Set GetSearchResult = Result
End Function

Пример, который печатает содержимое td с именем класса pText внутри таблицы, содержащей результаты поиска 

Sub Main()
Dim Document As Object
Set Document = GetSearchResult(ChurchLocation:="London")
Dim ResultRows as Object
Dim ResultRow As Object
Set ResultRows = Document.getElementsByTagName("table")(8).getElementsByTagName("td")
For Each ResultRow in ResultRows
    If ResultRow.Classname = "pText" Then
        Debug.print ResultRow.innerText
    End If
Next
End Sub

Обновление Вам нужно добавить пару ссылок в ваш проект VBA, чтобы следующий код работал.

В редакторе VBA перейдите в меню «Инструменты», нажмите «Ссылки» и в открывшемся диалоговом окне добавьте флажок рядом со следующими двумя элементами: Microsoft XML, v6.0 и Microsoft HTML Object Library (

Public Function GetChurchDetails(ByVal ChurchID As String) As MSHTML.HTMLDocument
Dim Request As New MSXML2.ServerXMLHTTP60
Dim Result As New MSHTML.HTMLDocument

Request.Open "GET", "http://www.ukchurch.org/churchdetails.php?churchid=" & ChurchID, False
Request.send

Result.body.innerHTML = Request.responseText
Set GetChurchDetails = Result
End Function

Sub Main2()
Dim Document As MSHTML.HTMLDocument
Dim Church As MSHTML.HTMLDocument
Set Document = GetSearchResult(ChurchLocation:="London")
Dim ResultRows As MSHTML.IHTMLElementCollection
Dim ResultRow As MSHTML.IHTMLElement
Dim ChurchID As String
'Set ResultRows = Document.getElementsByTagName("table")(8).getElementsByTagName("td")
' all result links on searchresults1.php have a classname of resultslink which makes getting them much easier
Set ResultRows = Document.getElementsByClassName("resultslink")
For Each ResultRow In ResultRows
    ChurchID = ResultRow.getAttribute("href")
    ChurchID = Mid(ChurchID, InStr(1, ChurchID, "=") + 1)
    Set Church = GetChurchDetails(ChurchID)
    ' code to read data from the page using Church as the Document
    ' eg: Church.getElemenetsByTagName("td").....
Next
End Sub

Вам нужно использовать только режим «post» при отправке данных, для всего остального вы можете использовать «get»

...