Добрый день уважаемые форумчане, помогите решить задачу.
Есть программа которая занимается парсингом нескольких сайтов, в целом выполняется 15 различных процедур. Парсинг построен на объекте InternetExplorer.Application На протяжении нескольких лет все работает, но есть некоторые проблемы с IE (в отделе несколько компов с разными версиями Windows и Ексель приходится лепить различные костыли для нормальной работы с IE, также не устраивает скорость выполнения парсинга некоторых сайтов).
Решил перейти на объект MSXML2.XMLHTTP, в целом все прошло успешно, 14 процедур работают отлично, скорость парсинга повысилась в разы.
Парсинг одной процедуры не возвращает корректные данные.
Вместо:
ТОВ "Наименование 1" 148 000,00 грн
ТОВ "Наименование 2" 163 440,00 грн
Выдает:
Initial bids Bidders
{{ bid_info.label[lang]||"-" }} You Normilized Price {{ bid_info['amount_features']|fraction }}
InternetExplorer до сегодняшнего дня возвращал корректные данные, сегодня тоже перестал.
Исследуя страницу в браузере обратил внимание, что появился новый тег <span, раньше его не было возможно в нем причина.
Перепробовал различные варианты запросов к странице, безрезультатно.
Помогите найти решение как получить нормальный ответ.
Пример кода
Код |
---|
Option Explicit
Option Compare Text
''' Для примера страница сайта с которой есть проблема XML
Private Const strURL As String = "https://auction.openprocurement.org/tenders/2889f213faf9415ba9d27e97fd675cd9"
Sub NotWorkingParser_XML()
Dim objHTMLDoc As HTMLDocument
''' объект objHTMLDoc As HTMLDocument, объявлен ранним связыванием
''' Tools -> References -> Microsoft HTML Object Library. > C:\Windows\SysWOW64\mshtml.tlb
Dim objXML As Object, Tag1, vl1
Dim strOtvetAukcion As String, strTrimer As String
Set objHTMLDoc = New HTMLDocument
Set objXML = CreateObject("MSXML2.XMLHTTP.6.0")
''' Формирование заголовка запроса
objXML.Open "GET", strURL, False
objXML.setRequestHeader "Accept", "*/*"
objXML.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:49.0) Gecko/20100101 Firefox/58.0.1"
objXML.setRequestHeader "Proxy-Connection", "Keep-Alive"
objXML.setRequestHeader "Cache-Control", "no-cache"
objXML.setRequestHeader "If-Modified-Since", "Thu, 1 Jan 1970 00:00:00 UTC"
objXML.setRequestHeader "Content-Type", "text/xml"
'''Чтобы браузер распарсил ответ сервера в свойство responseXML, _
в ответе должен быть заголовок Content-Type: text/xml. Иначе свойство responseXML будет равно null.
'''objXML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objXML.sEnd
''' Получить ответ
While objXML.readyState <> 4: DoEvents: Wend
objHTMLDoc.body.innerHTML = objXML.responseText
''' ===========================================
''' В процессе реализации получить ответ использовались различные методы
''' getElementById, getElementsByClassName, getElementsByTagName
''' setRequestHeader "Content-Type", "text/xml", "application/x-www-form-urlencoded", "text/html"
''' objHTMLDoc.body.innerHTML = ConvertBytesToString(objXML.responseBody)
''' ничего не помогло (:
''' ===========================================
''' статус аукциона
Set Tag1 = objHTMLDoc.getElementsByClassName("header-auction-item navbar-brand pull-left round-info timer-text")
Debug.Print Trim$(Tag1.Item(0).innerText) & vbNewLine
''' набор данных шаги аукциона
For Each Tag1 In objHTMLDoc.getElementsByClassName("auction-round")
For Each vl1 In Tag1.Children
strTrimer = Trim$(Application.WorksheetFunction.Clean(vl1.innerText))
strOtvetAukcion = strOtvetAukcion & strTrimer & vbNewLine
Next
Debug.Print strOtvetAukcion & vbNewLine
strOtvetAukcion = vbNullString
Next
Set objHTMLDoc = Nothing
Set objXML = Nothing
End Sub
Sub NotWorkingParser_IE()
''' Минусы работы с InternetExplorer
''' 1. Проблемы возникают при наличии в отделе нескольких компов с разными версиями Windows, IE
''' 2. Скорость выполнения парсинга сайтов. По сравнению с XML иногда достигает разницы в десятки раз.
Dim objIE As Object
Dim strOtvetAukcion As String, strTrimer As String
Dim Tag1, vl1
Set objIE = CreateObject("InternetExplorer.Application"):
objIE.navigate strURL
DoEvents
While objIE.busy Or (objIE.readyState <> 4): DoEvents: Wend
' Do While objIE.busy Or (objIE.readyState <> 4)
' DoEvents: Application.Wait (Now + TimeValue("0:00:02"))
' Loop
''' статус аукциона
Set Tag1 = objIE.document.getElementsByClassName("header-auction-item navbar-brand pull-left round-info timer-text")
Debug.Print Trim$(Tag1.Item(0).innerText)
''' набор данных шаги аукциона
For Each Tag1 In objIE.document.getElementsByClassName("auction-round")
For Each vl1 In Tag1.Children
strTrimer = Trim$(Application.WorksheetFunction.Clean(vl1.innerText))
strOtvetAukcion = strOtvetAukcion & strTrimer & vbNewLine
Next
''' ответ веб-страницы
Debug.Print strOtvetAukcion
strOtvetAukcion = vbNullString
Next
objIE.Quit: Set objIE = Nothing
End Sub
Private Function ConvertBytesToString(ArrByte)
Dim ADOStream
Set ADOStream = CreateObject("ADODB.Stream")
With ADOStream
.Type = 1 'adTypeBinary
.Open: .Write ArrByte: .Position = 0
.Type = 2 'adTypeText
.Charset = "windows-1251"
ConvertBytesToString = .ReadText
.Close
End With
Set ADOStream = Nothing
End Function
|