excel - 从 Internet 服务器 VBA Excel 取件时间

Question

是否有可以在 Excel 2007 中运行的 VBA 代码，它可以从众所周知的 Internet 服务器中检索日期和时间？我需要这个来根据检索到的日期和时间调用宏。代码不应将值粘贴到任何地方，而是将日期和时间存储在变量中。

例如，网址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