Макрос проверки доступности веб-ресурса

Данная функция позволяет проверить, доступен ли тот или иной веб-ресурс с вашего компьютера, и получить код состояния HTTP

Как известно, при переходе по ссылке (URL), веб-сервер возвращает код состояния HTTP.

Наиболее популярный коды ответа веб-сервера: (перечень всех кодов состояния можно посмотреть в Википедии)

  • 200 OK («хорошо»)
  • 403 Forbidden («запрещено»)
  • 404 Not Found («не найдено»)

Код состояния - это целое число из 3 цифр.
По первой цифре можно определить, доступен ли ресурс: если первая цифра 2, то ресурс доступен, если любая другая - то скорее всего нет.

Пример макроса, проверяющего доступ к различным ресурсам по URL:

Sub ПроверкаURL()
    URL$ = "http://excelvba.ru/resources/FillDocuments"    ' ссылка на каталог
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 200 (папка существует, доступ открыт)

    URL$ = "http://ExcelVBA.ru/updates/"    ' ссылка на каталог
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 403 (папка существует, но доступ к ней закрыт)

    URL$ = "http://ExcelVBA.ru/mail.jpg"    ' ссылка на файл
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 200 (файл существует, доступен)

    URL$ = "http://excelvba.ru/code/GetURLstatus"    ' ссылка на веб-страницу
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 200 (веб-страница существует, доступна)

    URL$ = "http://excelvba.ru/error-test-macro"    ' ссылка на веб-страницу
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 404 (веб-страница по такой ссылке не найдена)

    URL$ = "http://excelvba.ru/.htaccess"    ' ссылка на недоступный файл
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 403 (файл существует, не доступен)

    URL$ = "excelvba.ru"    ' неверная ссылка - без «http://»
    MsgBox GetURLstatus(URL$), vbInformation, URL$    ' возвращает 0 (URL в неверном формате - запрос не выполнен)
End Sub

Код функции GetURLstatus, позволяющий выполнять такую проверку веб-ресурсов:

Function GetURLstatus(ByVal URL$) As Long
    ' функция проверяет наличие доступа к ресурсу URL$ (файлу или каталогу)
    ' возвращает код ответа сервера (число), либо 0, если ссылка ошибочная
    ' (200 - ресурес доступен, 404 - не найден, 403 - нет доступа, и т.д.)
    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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Похоже, это связано с тем, что Дропбокс прекратил поддержку IE11

Игорь, вот не подумайте, что денег жалко, но не спортивно это как-то, сам поковыряюсь. Я в общем и не искал готовое решение, просто хотел посоветоваться, как такое может быть. После четырех лет работы вдруг перестает работать, причем только https://www.dropbox.com/

Алексей, тут надо не идеями делиться, а проверять макрос на ваших данных, и дорабатывать макрос для решения проблемы.
Могу сделать под заказ. По цене - около 1500 руб.

Добавил исправление. 200-->400
Игорь, есть у меня один макрос в котором я использовал предложенный Вами способ для тестирования доступа к https://www.dropbox.com/ и он работал года три. Но вот в ночь с 15 на 16 декабря перестал: все время выдает 400!
На десяток других сервисов реагирует нормально. И вообще не нашел других косячников. Уже сутки бьюсь, друзья помогали.. Может поделитесь идеями?

Мои макросы работают только под Windows
Для Мак - нужны совсем другие макросы, с этим помочь не смогу

Не работает, возвращает всегда 0. Проверял на Макбуке, может там, что-то по другому работает.

Можно ли определить имя открытого сайта,через VBA?

Макрос немного изменить надо, чтобы можно было таймаут задать.
Возьмите за основу код функции GetResponse
с этой страницы: http://excelvba.ru/code/GetHTTPResponse

При сканировании IPTV плей листа, на некоторых макрос висит, как ограничить время ?

Елена, с этим не могу помочь, - у меня нет Mac для тестирования кода
Под Parallels и этот код заработает, а из-под MacOS надо что-то совсем другое делать

Здравствуйте. А как сделать такой макрос только для Mac?

Слава, Богу ! Нашел, то что нужно! Спасибо , автору макроса!

Спасибо!!!

еще можно добавить
txt = Replace(txt, " ", "%20")

круто! спасибо, ссылки вылечились!

Пётр, этот вариант поможет обойтись без списка замен:

Function GetURLstatus(ByVal URL$) As Long
    ' функция проверяет наличие доступа к ресурсу URL$ (файлу или каталогу)
    ' возвращает код ответа сервера (число), либо 0, если ссылка ошибочная
    ' (200 - ресурес доступен, 404 - не найден, 403 - нет доступа, и т.д.)
    On Error Resume Next: URL$ = Replace(URL$, "\", "/")
    URL$ = URLEncode(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
 
Function URLEncode(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = "%" & Hex(AscW(l) \ 64 \ 64 + 224) & "%" & Hex(AscW(l) \ 64) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case 32: t = "+"
            Case Else: t = l
        End Select
        URLEncode = URLEncode & t
    Next
End Function

наверное что то типа этого http://excelvba.ru/code/URLEncode
но в ссылках попадаются и «» и символы à и ö
так что пока только вручную составляю таблицу соответствий для replace потихоньку

если в ячейку введен верный URL, то это "проблема" уже не самой ячейки
а значит нужно предварительно преобразовать ссылку перед дальнейшей обработкой
например перед GetURLstatus или перед скачкой файла
чтобы это делать вручную - еще нужно выявить эти ссылки и выявить такие символы, которые нужно подменить на верные
но благо, что хотя бы такой метод через Replace хорошо работает

а есть какой то макрос, который сам проверит каждый символ в URL и преобразует в нужный?
чтобы не составлять список replace, какой символ на что заменить перед обработкой

спасибо

Добавьте в начало функции GetURLstatus:

    URL$ = Replace(URL$, "’", "%E2%80%99")
    URL$ = Replace(URL$, "‘", "%E2%80%98")

и всё будет работать.

В ваших ссылках - недопустимые символы.
При вводе такой ссылки в браузер, он сам преобразует эти символы в их коды
А функция GetURLstatus такой конвертации не выполняет, — потому и возвращалась 404 ошибка.

abc = GetURLstatus(http://www.old-games.ru/ games/pc/turn_n_burn/ turn_‘n_burn_cover.jpg")
теперь эта 404, а прошлая, которая wolverine, - 200

*можно объединить три комментария в один?

наверное из-за апострофа?
а как правильно скормить ссылку ?

почему выдает 404 ?
abc = GetURLstatus("http://www.old-games.ru/games/ pc/x-2_wolverine’s_revenge/ x-2_wolverine’s_revenge_cover.jpg")

картинка же в браузере открывается

Спасибо!

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _  __  _____   _       _____   _____   _     
| |/ / |___ / | | |_ _| | ____| | |__
| ' / |_ \ | | | | | _| | '_ \
| . \ ___) | | |___ | | | |___ | | | |
|_|\_\ |____/ |_____| |_| |_____| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.