Скачивание исходного кода 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


А эту заготовку кода я использовал, когда писал макросы для загрузки данных с сайтов
(последние несколько лет подобные макросы не пишу, ибо сделал универсальную надстройку «Парсер сайтов», в которой всё это реализуется 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...
код этой страницы содержит только часть товара, которые показаны на ней, как извлечь код со всеми товарами на этой странице?

Все отлично работает, большое Вам спасибо!

Вот как-то так это делается:

Sub test()
    URL = "https://www.finam.ru/profile/mosbirzha-fyuchersy/1mfr-1-20-mff0_mff0/export/"
    txt = GetHTTPResponse(URL)
 
    txt = Split(txt, "Finam.IssuerProfile.Main.issue")(1)
    txt = Split(txt, """quote"":")(1)
    txt = Split(txt, """id"": ")(1)
    txt = Split(txt, ",")(0)
 
    MsgBox txt ' или Range("a5") = txt
End Sub

Здравствуйте Игорь! Хочется сказать Вам огромное спасибо за предоставления нам пользователям 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://"

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

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.

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

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

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

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