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

Вложения:

Комментарии

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

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

Какую функцию использовали?
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

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

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

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

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

Да, можно.
Но к коду получения исходного текста веб-страницы это не имеет отношения.

Вариантов несколько, вот 2 из них, которыми бы я воспользовался
(выбрал бы один из вариантов, в зависимости от конкретного сайта):

1. Скачать ТЕКСТ (а не ИСХОДНЫЙ КОД) веб-страницы, и обработать полученную текстовую строку макросом, получив из неё массив значений.
Потом этот массив записать на лист.

2. Использовать веб-запрос.
Это куда проще, если веб-страница нормально структурирована.
Тут даже макросы не нужны - запрос составляется через инструментарий Excel буквально за несколько секунд.
И обновлять запрос очень легко - достаточно нажать одну кнопку («Обновить»).

А как можно таблицу загруженную с сайте (то есть в HTMLе),раложить по ячейкам в Excel.
А то получается все в сплошные строки, без разделителей.
Пример кода:

Время
Плавка
Марка
Тн.

C
Mn
Si
S
P
Cr
Ni
Cu
Al
Ti
Mo
V
W
N2
As
B
Ca

03.02.12 03:46134757 041 .1510 1.2300 .4100 .0150 .0120 .0430 .0360 .0290 .0290 .0037

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

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

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

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