VBA, MS Access MS Access в примерах

Проверка валидности 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)

Назад ToTop
L.E. 30.12.2017
Рейтинг@Mail.ru