![]() |
![]() |
||
Проверка валидности URL (Ссылки)Public Function GetUrlStatus(URL$) As Boolean 'es - 09.12.2016 '-------------------------------------------------------------------- ' Функция проверяет наличие доступа к ресурсу URL$ (без учёта возможного редиректа!) ' Возвращает = True - False (Boolean) - Доступен ли ресурс ? '-------------------------------------------------------------------- Dim objXMLHTTP As Object On Error Resume Next URL = Trim(URL) Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP") With objXMLHTTP .Open "GET", URL, False .send 'Debug.Print .Status & " - " & .StatusText If .Status = 200 Then GetUrlStatus = True 'Проверяем статус End With Set objXMLHTTP = Nothing Err.Clear End Function
По материалам: http://www.mrexcel.com/forum/excel-questions/639463-check-if-url-exists.html Public Function GetURLStatus(ByVal URL As String, Optional bAllowRedirects As Boolean) ' - проверяет доступ к ресурсу по URL '-------------------------------------------------------------------------- ' Written: April 29, 2012 ' Author: Leith Ross ' Summary: Returns the status for a URL along with the Page Source HTML text. '-------------------------------------------------------------------------- 'Содрано (и чутка подравлено) с : ' http://www.mrexcel.com/forum/excel-questions/639463-check-if-url-exists.html '-------------------------------------------------------------------------- Dim httpRequest As Object ' Dim PageSource$ - Тут тело страницы не нужно Const WinHttpRequestOption_EnableRedirects = 6 If httpRequest Is Nothing Then On Error Resume Next Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1") If httpRequest Is Nothing Then Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5") End If Err.Clear On Error GoTo 0 End If ' Control if the URL being queried is allowed to redirect. httpRequest.Option(WinHttpRequestOption_EnableRedirects) = bAllowRedirects ' Clear any pervious web page source information ' PageSource = "" ' Add protocol if missing If InStr(1, URL, "://") = 0 Then URL = "http://" & URL End If ' Launch the HTTP httpRequest synchronously On Error Resume Next httpRequest.Open "GET", URL, False If Err.Number <> 0 Then ' Handle connection errors GetURLStatus = Err.Description Err.Clear Exit Function End If On Error GoTo 0 ' Send the http httpRequest for server status On Error Resume Next httpRequest.Send httpRequest.WaitForResponse If Err.Number <> 0 Then ' Handle server errors 'PageSource = "Error" GetURLStatus = Err.Description Err.Clear Else ' Show HTTP response info GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText ' Save the web page text ' PageSource = httpRequest.ResponseText End If On Error GoTo 0 End Function
Private Sub ValidateURLs()
'Пример экссплуотации
Dim Status As String
Status = GetURLStatus("http://forum.chandoo.org/threads/validate-url.32123/")
Debug.Print Status
If Status = "200 - OK" Then
MsgBox "URL OK"
Else
MsgBox "URL not ok"
End If
End Sub
Achtung! |
![]() ![]() |
||
L.E. 30.12.2017 |