mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Скачивание исходного кода 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 КБ552 недели 3 дня назад

Комментарии

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

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

Да, спасибо, действительно работает.
Но, видимо у меня была задержка с загрузкой самого сайта.
добавил несколько секунд ожидания, все начало грузиться отлично.
Еще раз спасибо.

Проверил, обе функции с этим сайтом работают,
обе возвращают ответ сайта (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 секунд. Заранее благодарю.

Все получилось.
Большое спасибо.

Конечно можно.
Добавьте эту строку кода перед строкой

GetHTTPResponse = .responseText

Вы совершено правы в случае «если у макроса (точнее, у Excel) есть доступ к интернету.»
Этот макрос изумительно работает на домашнем компьютере, на рабочем же не происходит считывание страниц ни с какого сайта.
В то же время первый вариант кода, без таймаута и библиотеки Microsoft WinHTTP Services 5.1, работает даже на рабочем компьютере, за исключением сайтов имеющих задерку «Verifying you're human...».
Можно ли в первый вариант кода ввести задерку типа «Application.Wait Now + 3 / 86400 ' пауза 3 секунды»?

Никакие «рекомендации» вам не нужны.
Я вам дал готовый код, который работает, если у макроса (точнее, у Excel) есть доступ к интернету.

Результат работы вашего макроса можно увидеть на скриншоте:
http://ExcelVBA.ru/pictures/20130423-1h7-102kb.jpg

Спасибо.
Библиотеку Microsoft WinHTTP Services 5.1 подключил.
Макрос отрабатывает до конца, табличка с кнопкой "ОК" выводится но текста считываемой страници нет.
Рекомендации в ответе " #13 Ильшат, 8 Сен 2012 - 23:16."
не дают результата.

Сергей, в статье написано, что надо сделать:

ВНИМАНИЕ: Надо подключить в Tools - References библиотеку Microsoft WinHTTP Services 5.1

При выполнении «ЭтаКнига.test», останавливается на - xmlhttp As WinHttpRequest,
Выскакивает табличка
Compile error:
User-defined type not defined
Что я не так сделал?

Здравствуйте, Сергей.

Мне хватило паузы в 2-3 секунды:

Function GetResponse(ByVal URL$) As String
    Const TIMEOUT& = 6    ' в секундах
    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
    Application.Wait Now + 3 / 86400    ' пауза 3 секунды

    If Not xmlhttp.WaitForResponse(TIMEOUT&) Then
        Debug.Print "timeout", URL: Exit Function
    End If
 
    GetResponse = xmlhttp.responsetext
End Function
 
Sub test()    ' пример использования
    txt = GetResponse("https://success-trade.net/")
    MsgBox txt
End Sub

Добрый день.

Используя функцию GetHTTPResponse для считывания исходного текста страницы, столкнулся со следующим:
На некоторых сайтах, при открытии страницы в качестве защиты от роботов, появляется строка «Verifying you're human...» на 10-30 сек и только потом загружается страница. Соответственно функция GetHTTPResponse считывает только «Verifying you're human...».
(пример такого сайта https:// success-trade . net/)
Возможно ли, сделать задержку на считывание, регулируемую по времени, либо другим путем обойти эту проблему?

Тут от версии Office ничего не зависит.
Сколько пользуюсь кодом - с подобной проблемой не сталкивался.

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

Во-первых, огромное спасибо за статью!

Подскажите, а Вы не сталкивались с проблемой, что в 2007 офисе данный код сохраняет страницу не до конца (сохраняет не более 32000 символов)? В чем может быть проблема?

Спасибо, все работает
Но есть необходимость получать данные, где необходимо авторизоваться

Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False, "akk", "pass"
        .send

Но авторизация не проходит

Алексей, проще всего сделать это через RegExp - регулярные выражения.

Если же достаточно проверять только начало строки - <тд align="center"><фонт class="grn">
то задача упрощается.

К примеру, исходный код страницы у вас находится в переменной txt

Для начала, разбиваем строку на массив, используя в качестве разделителя текст <тд align="center"><фонт class="grn">:

arr = split(txt,"<td align=""center""><font class=""grn"">")
' обратите внимание - внутри строки кавычки дублируются

Потом проходим в цикле по этому массиву, оставляя от каждого элемента текст до символа "<":

    For i = 1 To UBound(arr) ' первый элемент массива пропускаем
        ' в переменной arr(i) - текст типа 1000</font></td>.....<td align="center"><font class="grn">
        v = split(arr(i),"<")(0) ' берем текст до <
        debug.print v ' выводим очередное искомое число - для вашего примера, это будет 1000
    Next i

Здравствуйте. Я получил код страницы. Все работает. Как мне получить все значения <td align="center"><font class="grn">1000</font></td> в макросе.
Их там 60 штук. значение 1000 - может быть любым, это для примера.

Скачать исходный код ВСЕГО сайта - нереально.
Но это в вашем случае и не требуется.

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

Универсального решения тут нет - макрос надо разрабатывать под конкретный сайт.
Оформляйте заказ - попробую помочь.

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

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

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

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