Проверка валидности 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!
Для подробностей по XMLHTTP - Небходимо подключить в референсах Microsoft XML, vX.X (3 - 6)