效果还是很不错，大家可以参考一下，适合对于时间有特殊要求使用。比如：使用当地时区却不使用当地时间
如果想实现定时校时可以添加一个定时任务，这里建议 Windows 7 以上使用 SYSTEM 权限，可以实现用户未登录也能自动校时。
'----- 设置部分，按照需求进行修改 -----
'获取时间的网站，建议选择相近的服务器
GetUrl = "http://www.baidu.com/"
'以 GMT 时区为基准偏移时间，单位：分。例如北京时间：8*60
OffsetMinute = 8*60
'----- 程序部分，非必要请不要修改 -----
On Error Resume Next
Set WMI = GetObject("winmgmts:{(Systemtime)}\\.\root\cimv2")
'----- 获取服务器时区 -----
Set Query = WMI.ExecQuery("Select * From Win32_ComputerSystem")
For Each Rows In Query
CurrentTimezone = Rows.CurrentTimezone
Next
Set Query = Nothing
If CurrentTimezone>0 Then
CurrentTimezone = "+" & Right("000" & CurrentTimezone, 3)
ElseIf CurrentTimezone<0 Then
CurrentTimezone = "-" & Right("000" & (-1*CurrentTimezone), 3)
Else
CurrentTimezone = "+000"
End If
'----- 获取远程时间 -----
For T=1 To 5 '5次内获取耗时小于1秒的时间
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
GetStart = Timer
XMLHTTP.Open "HEAD", GetUrl, False
XMLHTTP.Send
'NewTime = Replace(Split(XMLHTTP.getResponseHeader("Date"), ",")(1), " GMT", "")
NewTime = XMLHTTP.getResponseHeader("Date")
GetEnd = Timer
Set XMLHTTP = Nothing
If GetEnd>=GetStart And GetEnd-GetStart<1 Then
Exit For
Else
NewTime = "Connect Timeout."
WScript.Sleep 5000 '暂停5秒
End If
Next
'----- 提取时间 -----
Set TimeRe = New RegExp
TimeRe.Global = False
TimeRe.MultiLine = False
TimeRe.IgnoreCase = False
TimeRe.Pattern = "^[A-Z][a-z]{2}\,\s(\d{2}\s[A-Z][a-z]{2}\s\d{4}\s\d{2}\:\d{2}\:\d{2})\sGMT$"
Set Matches = TimeRe.Execute(NewTime)
If Matches.Count>0 Then
NewTime = Matches(0).SubMatches(0)
NewTime = DateAdd("n", OffsetMinute, NewTime)
WMITime = Year(NewTime) & Right("0" & Month(NewTime), 2) & Right("0" & Day(NewTime), 2)
WMITime = WMITime & Right("0" & Hour(NewTime), 2) & Right("0" & Minute(NewTime), 2) & Right("0" & Second(NewTime), 2)
WMITime = WMITime & ".000000" & CurrentTimezone
'----- 设置时间 (需要管理员或SYSTEM权限) -----
Set Query = WMI.ExecQuery("Select * From Win32_OperatingSystem")
For Each Rows In Query
Rows.SetDateTime WMITime
Next
Set Query = Nothing
End If
Set Matches = Nothing
Set TimeRe = Nothing
Set WMI = Nothing