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 КБ544 недели 4 дня назад

Комментарии

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

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

Все оказалось предельно просто. В 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) по каждой ссылке с каждой страницы загружаем файл

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

Добрый день!

Подскажите, пожалуйста, можно ли как-то скачать исходный код всего сайта, а не только страницы?

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

Из этого следует вопрос можно ли как-то получить исходный код всех страниц? Или возможно есть другой вариант решения данной задачи?

Ильшат, я тут недавно редактировал код функции, и допустил ошибку.
Надо строку

sHTMLBody = .responseText

поменять на
GetHTTPResponse = .responseText

Внёс исправления в статью.

Не получается. Пустой файл сохраняет. Разные урл скармливал. Очень нужна данная функция. Если можете подправьте. Буду очень признателен.

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

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

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

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