Функция GetRealTime выполняет HTTP-запрос к заданному серверу,
и из заголовка Date ответа сервера берёт текущее время и дату.
Сделано на примере сервера Яндекса (их сайт почти всегда доступен, и работает очень быстро)
Функция полезна, когда надо получить реальную дату (а не ту, которая выставлена на компе), - например, для вычисления оставшегося времени использования trial-версии программы.
Пример использования:
Sub ВывестиТекущуюДатуИВремя() t = GetRealTime MsgBox t, vbInformation, "Текущее время (в Москве)" t = GetRealTime(6) ' GMT + 6 MsgBox t, vbInformation, "Текущее время (в Екатеринбурге)" End Sub
Код функции GetRealTime:
Function GetRealTime(Optional ByVal GMT& = 4) As Date ' © 2021 ExcelVBA.ru On Error Resume Next: Err.Clear: Dim http As Object, URL$, GMT_Time$, m$, mv$ 'GetRealTime = Now ' значение по-умолчанию Set http = CreateObject("Microsoft.XMLHTTP") URL$ = "https://yandex.ru/" ' можно указать практически любой сайт http.Open "GET", URL$, False http.Send GMT_Time = http.GetResponseHeader("Date") Set http = Nothing ' пример полученной строки: Sun, 27 Apr 2014 06:14:44 GMT If Not (GMT_Time Like "???, *# ??? #### ##:##:##*GMT*") Then Exit Function GMT_Time = Trim(Split(GMT_Time, ",")(1)) GMT_Time = Trim(Split(GMT_Time, "GMT")(0)) m$ = Trim(Split(GMT_Time)(1)) mv$ = (InStr(1, "janfebmaraprmayjunjulaugsepoctnovdec", m$, vbTextCompare) + 2) / 3 GMT_Time = Replace(GMT_Time, " " & m$ & " ", "." & Format(mv$, "00") & ".") GetRealTime = CDate(GMT_Time) + Val(GMT&) / 24 End Function
Комментарии
Здравствуйте.
Очень нужна функция получения Даты из интернета.
Почему то Ваша выдает ошибку "Неопознанная ошибка" на http.Send
если отключить On Error
В чем может быть дело?
GMT_Time = CDate(Replace(GMT_Time, m$, mv$)) вместо того, что с Format?
Антону в сообщении от "8 Сен 2014 - 13:21" не пришлось бы изобретать
Добрый день,
Скажите пожалуйста, а как сделать так, что бы отображалось только время, без даты?
Еще раз добрый день,
Я вроде разобрался. Если заменить "." на "/" в строке:
GMT_Time = Replace(GMT_Time, " " & m$ & " ", "." & Format(mv$, "00") & ".")
... то работает в обоих кодировках
С уважением к вам и вашей работе,
Антон
Добрый день, Игорь!
Извините, совсем не хотел вас обидеть. Я часто полюзуюсь вашими макросами и они отличные. Clear/Clean - моя опечатка, добавлял вручную, пока писал вам сообщение. В коде был Clear.
Я бы не стал лезть в макрос, если он бы у меня работал. Я только сейчас разобрался, в чем было несоответствие. Ваш макрос работает, если в Панели управления Windows выбран русский язык (Языки и региональные настройки - наверно так она должна называться в русском Windows). Я же использую раскладку UK, но с обычным представлением даты DD/MM, а не наоборот как у британцев. При этой кодировке я получаю вместо даты - "00:00:00"
Как можно изменить ваш макрос, чтобы он отображал дату вне зависимости от языковых настроек?
Заранее спасибо!
С уважением к вам и вашей работе,
Антон
Антон, вот есть на сайте функция, она работает (в этом можно убедиться)
Вы, зачем-то, её переделываете, допуская синтаксические ошибки, - а потом жалуетесь, что не работает.
Нафига переделывать то, что работает? 5 строк сэкономили?
зачем менять Err.Clear на Err.Clean ???
зачем вырезать из функции 2 нужные строки?
оставьте функцию как есть (если хотите, чтобы все работало), - и не занимайтесь ерундой...
Игорь, еще раз добрый день!
Проверил вашу фунцию GetRealTime такой как она есть в Excel2003 и 2010
получил ответ - 00:00:00
Отключил игнирорование ошибок - получил "Run-time error '13'. Type mismatch"
Очень нужна ваша помощь!
Мне очень нужно получить реальную дату из инета в формате "дата", напр. 05/09/14
Заранее огромное спасибо!
С уважением, Антон
Добрый день, Игорь!
Очень нужна ваша помощь со следующим кодом (код ваш, но был немножко подредактирован)
Function Ctrlkb() As Date
On Error Resume Next: Err.Clean: Dim http As Object, URL$, colum$, m$, mv$: Set http = CreateObject("Microsoft.XMLHTTP")
URL$ = "http://ya.ru/": http.Open "GET", URL$, False: http.Send: colum = http.GetResponseHeader("Date")
Set http = Nothing: If Not (colum Like "???, *# ??? #### ##:##:##*GMT*") Then Exit Function
colum = Trim(Split(colum, ",")(1)): colum = Trim(Split(colum, "GMT")(0)): colum = Trim(Left(colum, 11)): Ctrlkb = CDate(colum)
End Function
На некоторых машинах нормально выдает дату нужном формате "Дата" :)
на других - "0:00:00"
Отключаем "On Error Resume Next: Err.Clean"
получаем "Run-time error '13'. Type mismatch"
или "Run-time error '70'. Permission denied"
Может быть что либо отключено в Excel?
Заранее спасибо!!!
С уважением, Антон
Пользовательские функции автоматически не пересчитываются.
Добавьте первой строкой в функцию
Application.Volatile Trueи при открытии файла, в событии Workbook_Open, запускайте пересчёт формул на скрытом листе
Здравствуйте,
столкнулся с проблемой: данный макрос автоматически не обновляет дату из интернета.
Ф-ция getrealtime(3) находится на скрытом и закрытом от редактирования листе. Аналогичная ф-ция сегодня() работает на таком листе. Как можно настроить getrealtime для автоматического обновления даты при открытии файла, а не только при вводе в ячейку? Причем передсчет формул включен, но тоже не помогает.
Отправить комментарий