[原创] VBS校准系统时间

batman

更新为自动判断时间格式，WIN7 XP测试通过，WIN8待测试：

'VBS校准系统时间 BY BatMan http://www.bathome.net
Dim objXML, Url, Message
Message = "恭喜你，本机时间非常准确无需校对！"
Set objXML = CreateObject("MSXML2.XmlHttp")
Url = "http://open.baidu.com/special/time/"
objXML.open "GET", Url, False
objXML.send()
Do Until objXML.readyState = 4 : WScript.Sleep 200 : Loop
Dim objStr, LocalDate
objStr = objXML.responseText
LocalDate = Now()
Set objXML = Nothing
Dim objREG, regNum
Set objREG = New RegExp
objREG.Global = True
objREG.IgnoreCase = True
objREG.Pattern = "window.baidu_time\((\d{13,})\)"
regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
Dim OldDate, BJDate, Num, Num1
OldDate = "1970-01-01 08:00:00"
BJDate = DateAdd("s", regNum, OldDate)
Num = DateDiff("s", LocalDate, BJDate)
If Abs(Num) >=1 Then
  Dim DM, DT, TM, objSHELL
  DM = DateAdd("S", Num, Now())
  DT = DateValue(DM)
  TM = TimeValue(DM)
  If InStr(Now, "午") Then
    Dim Arr, Arr1, h24
    Arr = Split(TM, " ")
    Arr1 = Split(Arr(1), ":")
    h24 = Arr1(0)
    If Arr(0) = "下午" Then
      h24 = h24 + 12
      Else
      If h24 = 12 Then h24 = 0
    End If
    TM = h24 & ":" & Arr1(1) & ":" & Arr1(2)
  End If
  Set objSHELL = CreateObject("Wscript.Shell")
  objSHELL.Run "cmd /cdate " & DT, False, True
  objSHELL.Run "cmd /ctime " & TM, False, True
  Num1 = Abs(DateDiff("s", Now(), BJDate))
  Message = "【校准前】" & vbCrLf _ 
    & "标准北京时间为：" & vbTab & BJDate & vbCrLf _
    & "本机系统时间为：" & vbTab & LocalDate & vbCrLf _
    & "与标准时间相差：" & vbTab & Abs(Num) & "秒" & vbCrLf & vbCrLf _
    & "【校准后】" & vbCrLf _
    & "本机系统时间为：" & vbTab & Now() & vbCrLf _
    & "与标准时间相差：" & vbTab & Num1 & "秒"
  Set objSHELL = Nothing
End If
WScript.Echo Message
复制代码

batman

回复 2# czjt1234


    是因为时间格式的问题，家里的电脑是12小时制。。。
　 已修改为24小时制，应该大多数系统时间都是24小时制吧。。。

batman

哼哼哈嘿！快使用WMI：

'VBS校准系统时间 BY BatMan http://www.bathome.net
Dim objXML, Url, Message
Message = "恭喜你，本机时间非常准确无需校对！"
Set objXML = CreateObject("MSXML2.XmlHttp")
Url = "http://open.baidu.com/special/time/"
objXML.open "GET", Url, False
objXML.send()
Do Until objXML.readyState = 4 : WScript.Sleep 200 : Loop
Dim objStr, LocalDate
objStr = objXML.responseText
LocalDate = Now()
Set objXML = Nothing
Dim objREG, regNum
Set objREG = New RegExp
objREG.Global = True
objREG.IgnoreCase = True
objREG.Pattern = "window.baidu_time\((\d{13,})\)"
regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
Dim OldDate, BJDate, Num, Num1
OldDate = "1970-01-01 08:00:00"
BJDate = DateAdd("s", regNum, OldDate)
Num = DateDiff("s", LocalDate, BJDate)
If Abs(Num) >=1 Then
  Dim DM, y, M, D, H, MI, S, NewDateTime 
  DM = DateAdd("S", Num, Now())
  y = Year(DM)
  M = Right(0 & Month(DM), 2)
  D = Right(0 & Day(DM), 2)
  H = Right(0 & Hour(DM), 2)
  MI = Right(0 & Minute(DM), 2)
  S = Right(0 & Second(DM), 2)
  '将时间转化成UTC格式
  NewDateTime = y & M & D & H & MI & S & ".000000+480"
  Dim objWMI, objItems, objItem
  Set objWMI = GetObject("winmgmts:{(systemtime)}!\\.\Root\Cimv2")
  Set objItems = objWMI.ExecQuery("Select * From Win32_OperatingSystem")
  For Each objItem In objItems
    objItem.SetDateTime NewDateTime
  Next
  Set objWMI = Nothing
  Num1 = Abs(DateDiff("s", Now(), BJDate))
  Message = "【校准前】" & vbCrLf _ 
    & "标准北京时间为：" & vbTab & BJDate & vbCrLf _
    & "本机系统时间为：" & vbTab & LocalDate & vbCrLf _
    & "与标准时间相差：" & vbTab & Abs(Num) & "秒" & vbCrLf & vbCrLf _
    & "【校准后】" & vbCrLf _
    & "本机系统时间为：" & vbTab & Now() & vbCrLf _
    & "与标准时间相差：" & vbTab & Num1 & "秒"
  Set objSHELL = Nothing
End If
WScript.Echo Message
复制代码