Массовая проверка статуса гиперссылки - PullRequest
Новая
       20

Массовая проверка статуса гиперссылки

1 голос
/ 15 мая 2019

У меня есть длинный список гиперссылок в Excel, и я хотел бы создать код, который проверяет выбор, ведут ли эти ссылки к странице с ошибкой или нет.

Я адаптировал код из этого поста Сортировать мертвые гиперссылки в Excel с VBA?

Тем не менее, каждый раз, когда я запускаю его, ошибка

"403 - Запрещено"

появляется независимо от того, работает ссылка или нет.

То, что я хотел бы, чтобы код, это написать в следующей ячейке приводит к странице 404 или нет. Я предполагаю, что проблема заключается в отсутствии дополнительной строки, разрешающей Excel следовать гиперссылке, но я не могу думать о том, как решить эту проблему.

Это код, который я использую: 

Sub CheckHyperlinks()    
    Dim oColumn As Range

    Dim oCell As Range
    For Each oCell In Selection    
        If oCell.Hyperlinks.Count > 0 Then   
            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = GetResult(oHyperlink.Address)
            oCell.Offset(0, 1).Value = strResult
        End If
    Next oCell
End Sub

Private Function GetResult(ByVal strUrl As String) As String
    On Error GoTo ErrorHandler

    Dim oHttp As New MSXML2.XMLHTTP60

    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    GetResult = oHttp.Status & " " & oHttp.statusText

    Exit Function

ErrorHandler:
    GetResult = "Error: " & Err.Description  
End Function

1 Ответ

0 голосов
/ 15 мая 2019

Ошибка возникает, например, если вы пытаетесь получить доступ к http://www.google.com, но он работает на https://www.google.com (вы можете проверить его с Debug.Print GetResult("https://www.google.com", где вы получите 200 OK в качестве результата)

Так что, очевидно,не следует перенаправлениям от http:// до https://, установленным Google.

В качестве альтернативы используйте объект WinHttpRequest , как указано ниже, вместо GetResult: 

Private Function GetResultExtended(ByVal strUrl As String) As String
    On Error GoTo ErrorHandler

    Dim xhr As Object
    Set xhr = CreateObject("WinHttp.WinHttpRequest.5.1")

    xhr.Option(6) = True 'follow redirects
    xhr.Open "HEAD", strUrl, False
    xhr.send

    GetResultExtended = xhr.Status & " " & xhr.statusText
    Exit Function

ErrorHandler:
    GetResultExtended = "Error: " & Err.Description
End Function

Вместо xhr.Option(6) вы также можете использовать xhr.Option(WinHttpRequestOption_EnableRedirects), если определите следующее перечисление WinHttpRequestOption над своей функцией: 

Option Explicit

Private Enum WinHttpRequestOption
    WinHttpRequestOption_UserAgentString
    WinHttpRequestOption_URL
    WinHttpRequestOption_URLCodePage
    WinHttpRequestOption_EscapePercentInURL
    WinHttpRequestOption_SslErrorIgnoreFlags
    WinHttpRequestOption_SelectCertificate
    WinHttpRequestOption_EnableRedirects
    WinHttpRequestOption_UrlEscapeDisable
    WinHttpRequestOption_UrlEscapeDisableQuery
    WinHttpRequestOption_SecureProtocols
    WinHttpRequestOption_EnableTracing
    WinHttpRequestOption_RevertImpersonationOverSsl
    WinHttpRequestOption_EnableHttpsToHttpRedirects
    WinHttpRequestOption_EnablePassportAuthentication
    WinHttpRequestOption_MaxAutomaticRedirects
    WinHttpRequestOption_MaxResponseHeaderSize
    WinHttpRequestOption_MaxResponseDrainSize
    WinHttpRequestOption_EnableHttp1_1
    WinHttpRequestOption_EnableCertificateRevocationCheck
End Enum
...