Добрый день уважаемые форумчане, помогите решить задачу.
Есть программа которая занимается парсингом нескольких сайтов, в целом выполняется 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, раньше его не было возможно в нем причина.
Перепробовал различные варианты запросов к странице, безрезультатно.
Помогите найти решение как получить нормальный ответ.
Пример кода
Есть программа которая занимается парсингом нескольких сайтов, в целом выполняется 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 |