Excel проверка ссылок на доступность, по кнопке

Question

Нашел скрипт, внедрил, вроде работает. Хочу сделать скрипт чтобы проверять сайты на работает или нет, ну заходит или нет.

Вообщем, нажимаешь кнопку проверить, идет проверка, и высвечивается надпись перед тем как присвоить статус у урла. Проверка..., так вот если на сайт заходит то меняется надпись на РАБОТАЕТ, если не заходит, сайт в блоке или не существует, то надпись должна меняться на НЕ РАБОТАЕТ, но она не меняется, у меня остается Проверка...

Как бы это проверить можно.

Использую такой скрипт.

Sub Кнопка1_Щелчок()
    
    Dim cell As Range
    Dim winHttpReq As Object
    Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    On Error GoTo l_error
        
    For Each cell In Range("Таблица1").Columns(1).Cells
        If cell.Value <> "" Then
      
        cell.Offset(0, 1).Value = "Проверка..."
        Call winHttpReq.Open("GET", cell.Value, False)
        
        Call winHttpReq.Send
        If winHttpReq.Status = 200 Then
            cell.Offset(0, 1).Value = "РАБОТАЕТ"
        Else
            cell.Offset(0, 1).Value = "НЕ РАБОТАЕТ"
        End If
        End If
        
l_error:

    Next cell
End Sub

На крине видно самый последний урл он не корректный, скрипт останавливает работу и выводит ошибку, если допустим в середине такой урл будет, то будет плохо, как бы это исправить, чтобы скрипт вывел ошибку что не корректный урл и попер дальше проверять.

А так же видно снизу 2 урл, по идеи на сайт не заходит, должно присвоиться надпись, Не работает, не заменяет Проверка..., надпись.

Answer 1

Нашел решение, ловите, помогли доработать код до идеала. Теперь в инете можно будет найти нормальный код ), этот.

Function GetURLstatus(ByVal URL$) As Long
    On Error Resume Next: URL$ = Replace(URL$, "\", "/")
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    xmlhttp.Open "GET", URL, "False"
    xmlhttp.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
    xmlhttp.send
    GetURLstatus = Val(xmlhttp.Status)
    Set xmlhttp = Nothing
End Function

Sub Кнопка1_Щелчок()
For Each cell In Range("Таблица1").Columns(1).Cells
If cell.Value <> "" Then
    cell.Offset(0, 1).Value = "Проверка..."
    s = cell.Value
    If UCase(Left(s, 4)) = "HTTP" Then
    ss = GetURLstatus(s)
    Select Case ss
    Case 200: cell.Offset(0, 1).Value = "РАБОТАЕТ"
    'Case 400 To 600: cell.Offset(0, 1).Value = "НЕ РАБОТАЕТ"
    Case Else: cell.Offset(0, 1).Value = "НЕ РАБОТАЕТ"
    End Select
    Else
    cell.Offset(0, 1).Value = "Некорректная ссылка"
    End If
End If
Next
End Sub

БЛОГ НА HUSL

Excel проверка ссылок на доступность, по кнопке

Ответы (1 шт):