Данная функция возвращает исходный текст 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.xls |
25 КБ |
58 |
10 недель 2 дня назад |
