Данная функция возвращает исходный текст web-страницы:
Function GetHTTPResponse(ByVal sURL As String) As String On Error Resume Next Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") With oXMLHTTP .Open "GET", sURL, False ' раскомментируйте следующие строки и подставьте верные IP, логин и пароль ' если вы сидите за proxy ' .setProxy 2, "192.168.100.1:3128" ' .setProxyCredentials "user", "password" .send GetHTTPResponse = .responseText End With Set oXMLHTTP = Nothing End Function
Пример использования функции GetHTTPResponse
Private Sub ПримерИспользованияФункции_GetHTTPResponse() ' считываем исходный текст страницы ExcelVBA.ru в переменную txt txt = GetHTTPResponse("http://ExcelVBA.ru") ' получаем путь к папке "Рабочий стол" ПутьКРабочемуСтолу = CreateObject("WScript.Shell").SpecialFolders("Desktop") ' сохраняем текст из переменной txt в файл PageText.txt на рабочем столе SaveTXTfile ПутьКРабочемуСтолу & "\PageText.txt", txt ' открываем созданный текстовый файл в Excel Workbooks.OpenText ПутьКРабочемуСтолу & "\PageText.txt" End Sub Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean On Error Resume Next: Err.Clear Set fso = CreateObject("scripting.filesystemobject") Set ts = fso.CreateTextFile(filename, True) ts.Write txt: ts.Close SaveTXTfile = Err = 0 Set ts = Nothing: Set fso = Nothing End Function
PS: Если вас интересует ТЕКСТ страницы - используйте эту функцию: http://excelvba.ru/code/GetWebPageText
Еще один вариант кода - где можно задать таймаут
(чтобы код не подвисал, если нет ответа от сайта в течение нескольких секунд)
ВНИМАНИЕ: Надо подключить в Tools - References библиотеку Microsoft WinHTTP Services 5.1
Const TIMEOUT& = 6 ' в секундах Function GetResponse(ByVal URL$) As String On Error Resume Next: Err.Clear Static xmlhttp As WinHttpRequest If xmlhttp Is Nothing Then Set xmlhttp = New WinHttpRequest xmlhttp.Open "GET", URL$, True: DoEvents xmlhttp.Send: DoEvents If Not xmlhttp.WaitForResponse(TIMEOUT&) Then Debug.Print "timeout", URL: Exit Function End If GetResponse = xmlhttp.responsetext End Function
Sub test() ' пример использования On Error Resume Next txt = GetResponse("http://ExcelVBA.ru/") Debug.Print Len(txt) ' возвращает длину текста: 62737 символов End Sub
Ещё один пример функции - с возможностью задать кодировку:
Sub ТекстВебСтраницы_вКодировке_Windows1251() URL$ = "http://ExcelVBA.ru/" MsgBox GetHTTPResponse(URL$) ' MsgBox GetHTTPResponse(URL$, "windows-1251") ' если бы сайт выдавал страницу в windows-1251 End Sub
Function GetHTTPResponse(ByVal URL$, Optional ByVal Encoding$) As String On Error Resume Next Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") With oXMLHTTP .Open "GET", URL$, False .Send If Len(Encoding$) Then With CreateObject("ADODB.Stream") filename$ = Environ("tmp") & "\response.txt" .Charset = Encoding$: .Type = 1 ' adTypeBinary: .Open: .Write oXMLHTTP.ResponseBody .SaveToFile filename$, 2 .Type = 2 'adTypeText .LoadFromFile filename$ GetHTTPResponse = .ReadText .Close End With Else GetHTTPResponse = .ResponseText End If End With Set oXMLHTTP = Nothing End Function
' еще один вариант макроса для загрузки страницы
Sub test_internet() On Error Resume Next URL$ = "http://ExcelVBA.ru/" Const TIMEOUT& = 6 ' в секундах Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1") xmlhttp.Open "GET", URL$, True: DoEvents xmlhttp.Send: DoEvents If Not xmlhttp.WaitForResponse(TIMEOUT&) Then MsgBox "timeout", URL: Exit Sub End If txt$ = xmlhttp.responsetext MsgBox txt, vbInformation, "Длина ответа: " & Len(txt) End Sub
А эту заготовку кода я использовал, когда писал макросы для загрузки данных с сайтов
(последние несколько лет подобные макросы не пишу, ибо сделал универсальную надстройку «Парсер сайтов», в которой всё это реализуется 1-2 простейшими командами)
Sub LoadInfo() ' On Error Resume Next Dim ra As Range: Set ra = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp)) If ra.Row = 1 Then MsgBox "На листе не найден список ИНН", vbCritical: Exit Sub Dim cell As Range, txt$, res$, result_cell As Range, v Const TIMEOUT& = 6: Static xmlhttp As Object If xmlhttp Is Nothing Then Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1") For Each cell In ra.Cells URL$ = "https://sbis.ru/contragents/" & Trim(cell) xmlhttp.Open "GET", URL$, True: DoEvents xmlhttp.Send: DoEvents If Not xmlhttp.WaitForResponse(TIMEOUT&) Then Debug.Print "timeout", URL Else txt$ = "": txt$ = xmlhttp.responsetext ' обработка ответа сервера ' функцию GetTags можно взять здесь: excelvba.ru/code/html res$ = "": res$ = GetTags(txt, "div", "class", "cCard__Content-Var", "config 1") res$ = Replace(res$, "%22", "'"): res$ = Replace(res$, """", "'") ' ищем в ответе нужные данные With cell.EntireRow .Cells(3) = Replace(GetValue(res$, "УставнойКапитал"), " ", "") .Cells(4) = GetValue(res$, "Статус") .Cells(5) = GetValue(res$, "ВыручкаСтатистика") .Cells(6) = GetValue(res$, "ПрибыльСтатистика") .Cells(7) = GetValue(res$, "Выручка") .Cells(8) = GetValue(res$, "Прибыль") .Cells(9) = GetValue(res$, "ЧисленностьСотрудников") End With End If Next cell End Sub
Комментарии
Здравствуйте, Сергей.
Часть данных браузер подгружает отдельными запросами (по другим ссылкам)
Посмотрите это видео
https://excelvba.ru/programmes/Parser/manuals/Loading_Pages_and_Logon
там рассказано, где в браузере в консоли это посмотреть надо
Здравствуйте!
https://russian.alibaba.com/machinery/engineering-construction-machinery...
код этой страницы содержит только часть товара, которые показаны на ней, как извлечь код со всеми товарами на этой странице?
Все отлично работает, большое Вам спасибо!
Вот как-то так это делается:
Здравствуйте Игорь! Хочется сказать Вам огромное спасибо за предоставления нам пользователям excel таких полезных макросов!
Пользуясь, случаем хочется у Вас узнать, как можно исправить следующую ошибку:
Используя вашу функцию Function GetHTTPResponse для следующей ссылки «https://www.finam.ru/profile/mosbirzha-fyuchersy/1mfr-1-20-mff0_mff0/export/», значение ячейки выдает ошибку. Я предполагаю, что так происходит из-за того что длина html кода превышает допустимое максимальное значение, предусмотренное для ячеек excel. В конечном итоге из html кода с помощью встроенных функций хотел вытащить значение "id" из 558 строчки «Finam.IssuerProfile.Main.issue = {"quote": {"id": 888174, "code": "SPFB.1MFR-1.20", "fullUrl": "mosbirzha-fyuchersy/1mfr-1-20-mff0_mff0", "title": "1MFR-1.20(MFF0)", "decp": 2, "testDriveEnabled": false, "market": {"id": 14, "title": "МосБиржа фьючерсы"».
Каким образом можно усовершенствовать код функции Function GetHTTPResponse, что-бы в ячейку выводилось сразу значение "id", а не весь код?
Спасибо, Игорь!
Сергей, такое ограничение обходится 2 способами:
1) использованием прокси-серверов
2) установкой паузы (1-2 сек) между запросами
Здравствуйте! При определенном количестве запросов функцией GetHTTPResponse возникает ошибка на сайте: 406 Not Acceptable. Через определенное время доступ к сайту возвращается. Это можно как-то обойти?
Эти два кода не совместимы между собой.
Надо либо в обоих случаях применять браузер, либо всё делать без использования браузера.
Для обоих вариантов, у меня на сайте есть примеры кода.
Пользуюсь данным исполнением формулы
Function GetHTTPResponse(ByVal URL$, Optional ByVal Encoding$) As String
On Error Resume Next
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
With oXMLHTTP
.Open "GET", URL$, False
.Send
If Len(Encoding$) Then
With CreateObject("ADODB.Stream")
filename$ = Environ("tmp") & "\response.txt"
.Charset = Encoding$: .Type = 1 ' adTypeBinary:
.Open: .Write oXMLHTTP.ResponseBody
.SaveToFile filename$, 2
.Type = 2 'adTypeText
.LoadFromFile filename$
GetHTTPResponse = .ReadText
.Close
End With
Else
GetHTTPResponse = .ResponseText
End If
End With
Set oXMLHTTP = Nothing
End Function
Но теперь на сайте появилась авторизация.
Нашел и адаптировал код, который автоматически лоснится на странице.
код. ниже. После авторизации функция GetHTTPResponse возвращает данные со страницы ввода логина и пароля....
Подскажите, что не так, как решить проблему?
Dim oIE As Object, sHTML As String
Dim tmp, i As Long
Sub ccc()
Set oIE = CreateObject("InternetExplorer.Application") 'запускаем explorer
oIE.Visible = 1 'видимость explorer - 0-скрыть 1-показать
s = "https://....." 'ссылка
oIE.Navigate (s) 'загружаем сайт
Do While oIE.Busy Or (oIE.ReadyState <> 4): DoEvents: Loop 'ждем загрузку
'Set maPageHtml = oIE.Document 'выбираем все данные
Set NodeList = oIE.Document.getElementsbyTagname("Input") ' выбираем все поля ввода
Set maPageHtml = oIE.Document: DoEvents: DoEvents
'Stop
If oIE.LocationURL = s Then
maPageHtml.getElementsByName("USER_LOGIN").Item(0).Value = "AALEKSANDROV"
maPageHtml.getElementsByName("USER_PASSWORD").Item(0).Value = "jngecr321"
'maPageHtml.getElementsByName("USER_REMEMBER").Item(0).Click
NodeList(6).Click
End If
oIE.Quit
End Sub
спасибо все заработало с исходным кодом как в статье
в начале адреса не хватало "http://"
я просто в свой макрос вставил вашу ссылку, - и, о чудо, всё заработало..
Пробовал а адресе sURL
www.sunray-34.ru/shop/?page=1&cpp=20
www.sunray-34.ru/shop/?page=1
все равно не грузиться
GetHTTPResponse = .ResponseText - пустое значение
В ссылке не должно быть символа #
ссылка для загрузки - то, что до символа #
Тогда загрузится
Если надо с # (что уже скрипт подгружает) - то для загрузки надо использовать браузер Internet Explorer
Добрый день
Подскажите пожалуйста в чем проблема. Функция GetHTTPResponse возвращает пустое значение для страницы
www.sunray-34.ru/shop/?page=1&cpp=20#wbStoreElementwb_element_instance34
другие страницы считывает нормально
Я вместо чтения .ResponseText
использую = GetResponse(.ResponseBody, "utf-8")
так как почти все сайты в utf-8 дают ответ
и тогда ваша проблема решится
код дополнительной функции перекодировки:
тогда еще доп.вопрос, как было указано ниже у некоторых
на Вин7 - вебстраницы пишутся в текстовый файл битые, вместо спец.символов- ?
запрос идет через winhttp 5.1 , контент тайп пробовал разные (и утф8)- ноль эмоций.
тот же самый запрос на windows server 2003 - пишет как надо в файл без ?.
Что за ерунда. в чем прикол...
Ничем не лучше. Я сам использую winhttp 5.1
В большинстве несложных макросов, они работают одинаково.
В своих проектах на VB6 для скачивания юзаю winhttp5.1 библиотеку,
так сайты долго отвечают использую
http.send
http.WaitForResponse (-1)
Иначе вылетает программа изза зависания ответов.
Вопрос - в чем использование MSXML2.XMLHTTP лучше/гибче?
если возможность обработки статуса отправки,приема?
Преобразовать HTML в текст (извлечь содержимое тегов) - не проблема.
Если же надо именно отформатированный текст в ячейках получить (списки, выделение жирным и курсивом, раскраска цветами, и прочее) - то это весьма проблематично
Что вы подразумеваете под форматированным текстом? Для чего вы делаете это преобразование?
Есть таблица в ячейках которой текст HTML с разметками нужно преобразовать в форматированный текст. Я не сильно разбираюсь VBA но все мои усилия по поиску решения без результата
Здравствуйте! Можете написать пример функции GetValue в примере макроса LoadInfo() ? спасибо.
Игорь, здравствуйте!
А есть ли возможность скачать видео через VBA?
Автоматизировать, - написав цикл, перебирающий строки листа, и для каждой строки делающий то, в чем вы уже разобрались
Плюс 2-3 строки к вашему коду
Добрый день. У меня вопрос. Макрос очень полезный. У меня есть массив ФИО клиента и ссылка на анкету его. Нужно сохранить исходный код каждой анкеты в каждый текстовый файл, где имя у txt файла ФИО клиента. По одиночке я понял как делать. Как все это автоматизировать?
Да, спасибо, действительно работает.
Но, видимо у меня была задержка с загрузкой самого сайта.
добавил несколько секунд ожидания, все начало грузиться отлично.
Еще раз спасибо.
Проверил, обе функции с этим сайтом работают,
обе возвращают ответ сайта (HTML код) длиной 15343 символов
Где-то вы с кодом перемудрили
не подскажите, не могу пропарсить сайт, но при обращении к странице и функция GetHTTPResponse и GetResponse возвращает пустое значение, хотя в браузере код виден нормально.
https://sales.russoutdoor.ru/sales/billboards/SPBB03104%D0%902/card.do?I...
Все оказалось предельно просто. В url содержались русские буквы ☺
Ваши макросы очень полезны. Спасибо
Здравствуйте, Максим.
Да, обычно причина такого ответа именно в отсутствии заголовков.
Но, возможны и другие причины (сбой на сайте, или неправильный запрос, - например, GET вместо POST)
если я правильно понимаю, то в случае если в файле с исходным кодом оказывается не то, что ожидалось (например фраза "При обработке запроса возникла ошибка. Мы уже разбираемся с данной проблемой."), то это значит, что сайт "понимает", что запрос идет не от браузера...
Т.е. нужно передавать заголовки?
У вас получилось что-нибудь реализовать по вашему замыслу? Я сейчас бьюсь над такой же задачей.
День добрый! Как сохранить код вэб-страницы, загруженную в IE с локального диска, с отмеченными элементами type="radio" (в исходной странице они не отмечены)?
Спасибо большое. Буду пробовать.
Да, можно
В Tools - References надо добавить ссылку на библиотеку Microsoft HTML Object Library
для преобразования загруженного исходного кода веб-страницы в объект, подойдет такая функция:
а потом использовать примерно так:
Здравствуйте.
Спасибо за Ваш проект.
Подскажите пожалуйста, можно ли используя VBA получить доступ к структуре документа (по аналогии с xml документами: дочерние записи, атрибуты и их свойства), а не просто получить в виде текста исходный код страницы. Если можно, то что почитать по данному функционалу, какой класс использовать и т.п.?
Смысл примерно такой: страница содержит кучу разнообразной информации, но также имеет ряд таблиц, причем таблицы от страницы к странице могут меняться (как наличие самой таблицы, так и ее структура). Хотелось бы сразу перемещаться от таблицы к таблице используя средства VBA и анализировать только их, а прочую информацию отбрасывать.
Заранее благодарен.
Дело в том, что эта страница в utf-8, но подставляя название этой кодировки в последний вариант, я получаю пустую строку.
Здравствуйте! Подскажите, пожалуйста, а как скачать код вот этой страницы - http://en.wiktionary.org/w/index.php?title=time&action=edit ? Я пытаюсь применять ваши макросы, но пока ничего не выходит. И, если можно, подскажите, как результат получать не в отдельной книге, а в той, откуда запускается макрос?
Mozgoed, всё отлично работает (без вопросиков) и без переделки функции (по крайней мере, на вашем примере с Яндексом):
А если сайт другой (какой-нибудь криво сделанный, где кодировка неверно выдается), - то тут могут быть вопросики, но универсального решения в этом случае не сделать.
"??????" (вопросики) Получилось исправить добавив объект "ADODB.Recordset":
Sub GetHttpSource()
Debug.Print getSourceHTTP("http://yandex.ru")
End Sub
Function getSourceHTTP(ByVal strURL) As String
Dim cResponseBody As Variant
Dim oXMLHTTP As Object
Set oXMLHTTP = CreateObject("Msxml2.XMLHTTP.4.0")
With oXMLHTTP
.Open "GET", strURL, False
.Send
cResponseBody = .ResponseBody
End With
Set oXMLHTTP = Nothing
Dim oRS As Object
Set oRS = CreateObject("ADODB.Recordset")
With oRS
.Fields.Append "Data", 200, LenB(cResponseBody), &H80
.Open
.AddNew
.Fields(0).AppendChunk cResponseBody
cResponseBody = oRS(o)
.Close
End With
Set oRS = Nothing
Debug.Print cResponseBody
End Function
Спасибо. Значит проблема в Windows7. Раньше был Windows server так же все работало.
C этой страницей - никаких проблем.
Подставил ссылку в пример использования функции GetHTTPResponse - всё работает, создаётся текстовый файл в кодировке Windows-1251,
в котором русские символы отображаются корректно.
Спасибо
Не получается определить кодировку страницы. Перепробовал кучу кодировщиков в разных вариантах, выдает не читаемый текст. Может быть есть еще проблемы?
Адрес страницы http://www.souzplastic.ru/catalog/18546/
Знаки вопроса выводятся, потому что на страницах сайта указана одна кодировка, а по факту - используется другая.
Попробуйте использовать функцию GetResponse
Если не поможет, - можно перекодировать текст (полученных с этого проблемного сайта), при помощи этой функции:
http://excelvba.ru/code/encode
при скачивании через GetHTTPResponse загружает исходный русские буквы меняет на ???????
если копировать и вставлять то получается нормально
причем такое получается только на одном сайте другие работают нормально.
Подскажите как исправить.
Еще возникла мысль: WebPageText использует же браузер для загрузки информации. А после его исполнения тот же пустой файл на выходе. Значит сайту безразлично с браузера ты зашел или нет. Или я чего-то не понимаю?
Не могу понять логику сайта. Он видит что запрос идет не через браузер, Пропускает N-ое количество первых запросов, А потом банит?
Проверил на функции GetResponse, - все работает
(через раз только таймаут вылетает, - надо не 6 поставить, а побольше)
Через пару минут стал снова проверять, - уже не работает.
Можно попробовать настроить подключение (задав заголовки запроса), - но тут надо много времени на тестирование, а у меня этого времени нет.
Видимо, по заголовкам запроса сайт видит, что обращение идёт не через браузер, - и отклоняет запрос.
Или же сайт просто банит за программные запросы.
также пустой файл выдает WebPageText (макрос для копирования текста с сайта, о котором идет речь в начале статьи). Притом только для newhomes.e1.ru.
В чем может быть причина?
и та и другая формирует пустой файл.
неделю назад пользовался GetHTTPResponse - все работало.
как перестала - попробовал GetResponse.
Отправить комментарий