Скачивание исходного кода web-страницы в текстовый файл

Данная функция возвращает исходный текст 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


А эту заготовку кода я использую, когда пишу макросы для загрузки данных с сайтов
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

ВложениеРазмерЗагрузкиПоследняя загрузка
GetHTTPResponse.xls25 КБ5935 недель 3 дня назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

спасибо все заработало с исходным кодом как в статье
в начале адреса не хватало "http://"

я просто в свой макрос вставил вашу ссылку, - и, о чудо, всё заработало..

Sub test_internet()
    On Error Resume Next
    URL$ = "http://www.sunray-34.ru/shop/?page=1&cpp=20"
 
    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

Пробовал а адресе 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 дают ответ
и тогда ваша проблема решится

код дополнительной функции перекодировки:

Function GetResponse(ByRef BytesArr, ByVal Encoding$) As String
    On Error Resume Next
    Dim ResponseFilename$
    Set ADODBStream = CreateObject("ADODB.Stream")
    With ADODBStream
        ResponseFilename$ = Environ("tmp") & "\response.txt"
        If Len(Encoding$) Then .Charset = Encoding$
        .Type = 1        ' adTypeBinary:
        .Open: .Write BytesArr
        .SaveToFile ResponseFilename$, 2
        .Type = 2        'adTypeText
        .LoadFromFile ResponseFilename$
        GetResponse = .ReadText
        .Close
        Kill ResponseFilename$
    End With
    Set ADODBStream = Nothing
End Function

тогда еще доп.вопрос, как было указано ниже у некоторых
на Вин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

для преобразования загруженного исходного кода веб-страницы в объект, подойдет такая функция:

Function HTMLtextToHTMLDocument(ByVal txt As String) As HTMLDocument
    On Error Resume Next
    Set HTMLtextToHTMLDocument = New HTMLDocument
    HTMLtextToHTMLDocument.body.innerHTML = txt
End Function

а потом использовать примерно так:

    Dim el As Object, doc As HTMLDocument
    Set doc = HTMLtextToHTMLDocument(txt)
    For Each el In doc.all ' перебираем в цикле все элементы на веб-странице
        Debug.Print el.TagName        ' тег (например, DIV или TABLE
        Debug.Print el.ClassName        ' название класса
        Debug.Print el.innerHTML        ' содержимое элемента
    Next el
    Set el = Nothing: Set doc = Nothing

Здравствуйте.
Спасибо за Ваш проект.

Подскажите пожалуйста, можно ли используя VBA получить доступ к структуре документа (по аналогии с xml документами: дочерние записи, атрибуты и их свойства), а не просто получить в виде текста исходный код страницы. Если можно, то что почитать по данному функционалу, какой класс использовать и т.п.?

Смысл примерно такой: страница содержит кучу разнообразной информации, но также имеет ряд таблиц, причем таблицы от страницы к странице могут меняться (как наличие самой таблицы, так и ее структура). Хотелось бы сразу перемещаться от таблицы к таблице используя средства VBA и анализировать только их, а прочую информацию отбрасывать.

Заранее благодарен.

Дело в том, что эта страница в utf-8, но подставляя название этой кодировки в последний вариант, я получаю пустую строку.

Здравствуйте! Подскажите, пожалуйста, а как скачать код вот этой страницы - http://en.wiktionary.org/w/index.php?title=time&action=edit ? Я пытаюсь применять ваши макросы, но пока ничего не выходит. И, если можно, подскажите, как результат получать не в отдельной книге, а в той, откуда запускается макрос?

Mozgoed, всё отлично работает (без вопросиков) и без переделки функции (по крайней мере, на вашем примере с Яндексом):

Sub test()        ' пример использования
    txt = GetResponse("http://yandex.ru")
    Debug.Print txt
End Sub

А если сайт другой (какой-нибудь криво сделанный, где кодировка неверно выдается), - то тут могут быть вопросики, но универсального решения в этом случае не сделать.

"??????" (вопросики) Получилось исправить добавив объект "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.

Какую функцию использовали?
GetHTTPResponse или GetResponse?

Если первую, - то попробуйте вторую, и ошибка наверняка исчезнет.

Добрый день.
Использовал этот код при сканировании базы newhomes.e1.ru
Еще неделю назад все работало отлично. Сейчас же при запросе к любому действующему объявлению код выдает пустой файл.
В чем может быть причина? Какая-то защита?

Здравствуйте. Пробую этот код и он работает только для некоторых сайтов (для этого сайта, рамблера), для других же возвращает пустой файл (яндекс, гугл, спортс и тп). Не подскажете, в чем причина?

Владлен, а вы попробуйте скопировать (это же секундное дело), - а потом спрашивайте...
Поскольку функция не задействует возможностей Excel, - то код без переделок будет работать и в VB6
Ну и в DLL можно вынести, при желании.

Добрый день! А можно ли эту функцию вынести в ДЛЛ? Если писать её на ВБ6 - какие-то будут изменения, или можно просто скопировать?

В том то и дело, что доступ есть, а синхронный запрос дает быстрый и правильный результат. А макрос, который я прислал тормозит примерно на 5 сек. и выдает 0. Ничего не понимаю.

У меня, ваша функция возвращает корректную дату, - 16.07.2013
Так что все работает. Ищите проблему в другом (может, у Excel нет доступа в интернет)

Наверное туплю... Но мне надо получать из интернета текущую дату. Я с помощью этой странички написал такой макрос:
Function current_date() As Date
Const sURI = "http://www.gov.ru/"
Const timeout& = 10
Dim htmlcode, htmlcode1 As String
On Error Resume Next
Err.Clear
Static xmlhttp As WinHttpRequest
If xmlhttp Is Nothing Then Set xmlhttp = New WinHttpRequest
xmlhttp.Open "GET", sURI, True: DoEvents
xmlhttp.Send: DoEvents
If Not xmlhttp.WaitForResponse(timeout&) Then
current_date = 0
Exit Function
End If
htmlcode = xmlhttp.ResponseText
htmlcode1 = Mid(htmlcode, InStr(1, htmlcode, """setDate"">") + 10, 10)
current_date = DateSerial(CInt(Right(htmlcode1, 4)), CInt(Mid(htmlcode1, 4, 2)), CInt(Left(htmlcode1, 2)))
End Function

но он всегда выдает мне 0. Видимо я что-то недопонимаю...

А вы прочитайте статью до конца, - и решение найдётся)

Еще один вариант кода - где можно задать таймаут
(чтобы код не подвисал, если нет ответа от сайта в течение нескольких секунд)

Здравствуйте. Как хорошо, что я нашел эту страничку, вот спасибо. Вот только не могу никак понять, как прерывать запрос и возвращать пустую строку, если запрос выполняется, например, более 10 секунд. Заранее благодарю.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ____    ___     ___    _   _   _____   _ 
/ ___| ( _ ) ( _ ) | | | | |___ / | |
| | _ / _ \ / _ \ | |_| | |_ \ | |
| |_| | | (_) | | (_) | | _ | ___) | | |
\____| \___/ \___/ |_| |_| |____/ |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.