mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Получение текущей даты и времени с сервера в интернете

Функция 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
    On Error Resume Next: Err.Clear: Dim http As Object, URL$, GMT_Time$, m$, mv$
    'GetRealTime = Now        ' значение по-умолчанию

    Set http = CreateObject("Microsoft.XMLHTTP")
    URL$ = "http://ya.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

Комментарии

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

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

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 нужные строки?

mv$ = (InStr(1, "janfebmaraprmayjunjulaugsepoctnovdec", m$, vbTextCompare) + 2) / 3
    GMT_Time = Replace(GMT_Time, " " & m$ & " ", "." & Format(mv$, "00") & ".")

оставьте функцию как есть (если хотите, чтобы все работало), - и не занимайтесь ерундой...

Игорь, еще раз добрый день!

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

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

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

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

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