Excel VBA: получите код ошибки для недопустимого URL-адреса в гиперссылке с помощью WinHttpRequest

Question

В Excel у меня есть список с URL-адресами. Мне нужно проверить, может ли IE (браузер по умолчанию) открыть их. Им не нужно открывать на самом деле, это проверить доступность. Если они не могут открыться, мне нужно изолировать код ошибки и поместить его в другой столбец.

После поиска здесь я начал со следующих гиперссылок и использовал GET для получения данных в MsgBox. Это, похоже, работает частично, но, конечно, теперь я получаю MsgBox с каждым URL-адресом также без ошибок. Также я ищу способ извлечь ошибку и поместить ее в активный лист.

То, что я получил до сих пор:

Sub Request_Data() 

' declare 
numRow = 2 
Dim MyRequest As Object 

' activate URLs without Follow 
Do While ActiveSheet.Range("C" & numRow).Hyperlinks.Count > 0 
numRow = numRow + 1 

' create request 
Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1") 
MyRequest.Open "GET", _ 
ActiveSheet.Range("C" & numRow) 

' send request 
MyRequest.Send 

' outcome 
MsgBox MyRequest.ResponseText 

' isolate the error code (for example 404) 
' place error code in excel sheet in column H next to row URL 
Loop 

End Sub 

ли кто-нибудь знает, как я должен поступить? Я думал, что это может быть полезно, но я не знаю, с чего начать. Checking for broken hyperlinks in Excel и Bulk Url checker macro excel

Заранее спасибо

Answer 1

Смотрите ниже код - вам нужно будет адаптировать Test подпрограмму к петле через ваши клетки и вызвать IsValidUrl для каждого значения вы хотите тест:

Option Explicit 

Sub Test() 
    MsgBox IsValidUrl("http://www.thisdoesnotexistxxxxxxxxxxxxx.com/") 
    MsgBox IsValidUrl("http://www.google.com/") 
    MsgBox IsValidUrl("http://www.ppppppppppppqqqqqqqqqqqqqqrrrrrrrrrrrrr.com/") 
End Sub 

Function IsValidUrl(strUrl As String) As Long 

    Dim objRequest As Object 
    Dim lngCode As Long 

    On Error GoTo ErrHandler 

    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1") 
    With objRequest 
     .Open "GET", strUrl 
     .Send 
     lngCode = 0 
    End With 

    GoTo ExitHandler 

ErrHandler: 
    lngCode = Err.Number 

ExitHandler: 
    Set objRequest = Nothing 
    IsValidUrl = lngCode 

End Function 

Мой вывод:

-2147012889 
0 
-2147012889