Время доставки с интернет-серверов VBA Excel

Question

Есть ли код VBA, который можно запустить в Excel 2007, который извлекает дату и время с очень известного интернет-сервера? Мне нужно это, чтобы вызвать макрос на основе даты и времени, которые были восстановлены. Код не должен вставлять значение в любом месте, но иметь дату и время, хранящиеся в переменной.

Например, url http://tycho.usno.navy.mil/cgi-bin/timer.pl ведет нас к веб-странице, которая имеет текущее время только для нескольких часовых поясов в США.

Answer 1

вы могли бы попробовать что-то вроде, ниже которого я в своей книге Personal.xls (нашел его несколько месяцев назад что-то):

Sub GetiNetTime() 

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 
' 
' The GetiNetTime macro is written by Karthikeyan T. 
' 
' Please Note: Original code adjusted here for setting Indian Standard Time, 
' India Standard Time (IST) = GMT+5:30 
' Time adjusted for BST by setting the 'Hr' variable = 1 to get GMT+1 
' 
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 

Dim ws 
Dim http 
Dim GMT_Time, NewNow, NewDate, NewTime, Hr, Mn ', Sc 

'Below line wont work since clock providers changed the URL. 
'Const GMTTime As String = "http://wwp.greenwichmeantime.com/time/scripts/clock-8/runner.php" 


'Updated URL to fetch internet time *** 
'Macro updated Date & Time: 27-Oct-12 1:07 PM 

    Const GMTTime As String = "http://wwp.greenwichmeantime.com/time/scripts/clock-8/runner.php?tz=gmt" 

On Error Resume Next 
Set http = CreateObject("Microsoft.XMLHTTP") 

http.Open "GET", GMTTime & Now(), False, "", "" 
http.Send 

GMT_Time = http.getResponseHeader("Date") 
GMT_Time = Mid$(GMT_Time, 6, Len(GMT_Time) - 9) 

'Set Indian Standard Time from Greenwich Mean Time. 
'India Standard Time (IST) = GMT+5:30 
    Hr = 1  'Hours. =1 for BST, 2 for Europe Time, 11 for Oz? 
    Mn = 0  'Minutes. 
    'Sc = 0  'Seconds. 

NewNow = DateAdd("h", Hr, GMT_Time) 'Adding 5 Hours to GMT. 
NewNow = DateAdd("n", Mn, NewNow) 'Adding 30 Minutes to GMT. 
'NewNow = DateAdd("s", Sc, NewNow) 'Adding 0 Seconds to GMT. 

MsgBox "Current Date & Time is: GMT " & NewNow, vbOKOnly, "GetiNetTime" 

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 
' 
' If you want to insert the new date & time in excel worksheet just unquote 
' the following lines, 
' 
' Sheets("Sheet1").Select 
' Range("A1").Select 
' ActiveCell.Value = NewNow 
' 
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 

'Insert current date & time in cell on selected worksheet. 
'Sheets("Sheet1").Select  'Select worksheet as you like 
'Range("A1").Select    'Change the destination as you like 
'ActiveCell.Value = NewNow 

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 
' 
' If you want to change the system time just unquote the following lines, 
' 
' Set ws = CreateObject("WScript.Shell") 
' NewDate = DateValue(NewNow) 
' NewTime = Format(TimeValue(NewNow), "hh:mm:ss") 
' ws.Run "%comspec% /c time " & NewTime, 0 
' ws.Run "%comspec% /c date " & NewDate, 0 
' Set ws = Nothing 
' 
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*' 

'Set ws = CreateObject("WScript.Shell") 
'Split out date. 
'NewDate = DateValue(NewNow) 

'Split out time. 
'NewTime = Format(TimeValue(NewNow), "hh:mm:ss") 

'Run DOS Time command in hidden window. 
'ws.Run "%comspec% /c time " & NewTime, 0 

'Run DOS Date command in hidden window. 
'ws.Run "%comspec% /c date " & NewDate, 0 

Cleanup: 
'Set ws = Nothing 
Set http = Nothing 

End Sub