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

• 41653 просмотра