Главная » Макросы для Excel » Макрос проверки доступности веб-ресурса

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

Данная функция позволяет проверить, доступен ли тот или иной веб-ресурс с вашего компьютера, и получить код состояния 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

  • 22791 просмотр

Комментарии

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

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".
Алексей, 24 Дек 2020 - 03:05.#1

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

Алексей, 18 Дек 2020 - 16:30.#2

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

Игорь (администратор сайта), 17 Дек 2020 - 23:44.#3

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

Алексей, 17 Дек 2020 - 21:48.#4

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

Игорь (администратор сайта), 12 Июл 2020 - 19:35.#5

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

Гость, 11 Июл 2020 - 23:10.#6

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

Сергей, 28 Фев 2020 - 20:23.#7

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

Игорь (администратор сайта), 4 Ноя 2017 - 14:37.#8

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

Гость, 4 Ноя 2017 - 14:23.#9

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

Игорь (администратор сайта), 13 Апр 2017 - 00:11.#10

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

Елена, 12 Апр 2017 - 23:01.#11

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

григорий, 28 Май 2015 - 20:21.#12

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

Владимир, 21 Янв 2015 - 01:31.#13

Спасибо!!!

Петр, 17 Дек 2014 - 18:53.#14

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

Петр, 17 Дек 2014 - 17:25.#15

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

Игорь (администратор сайта), 17 Дек 2014 - 17:15.#16

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

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

Петр, 17 Дек 2014 - 16:32.#17

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

Петр, 17 Дек 2014 - 16:09.#18

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

Петр, 17 Дек 2014 - 15:53.#19

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

Петр, 17 Дек 2014 - 15:14.#20

спасибо

Игорь (администратор сайта), 17 Дек 2014 - 14:41.#21

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

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

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

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

Петр, 17 Дек 2014 - 14:33.#22

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

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

Петр, 17 Дек 2014 - 14:19.#23

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

Петр, 17 Дек 2014 - 14:09.#24

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

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

uuuulala, 27 Янв 2014 - 18:57.#25

Спасибо!

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

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

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

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