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

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

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