call runAsAdmin()
strNewDateTime = convertDateTime(getBaiduTime())
call syncDateTime(strNewDateTime, Now())

Function getBaiduTime()
    Dim strUrl, strText
    strUrl = "http://open.baidu.com/special/time/"
    With CreateObject("MSXML2.XmlHttp")
        .Open "GET", strUrl, False
        .Send()
        strText = .responseText
    End With
    strText = Split(LCase(strText), "window.baidu_time(")(1)
    getBaiduTime = Int(Left(strText, 13)/1000)
End Function

Function convertDateTime(intUnixTime)
    Dim objWMI, colOSes, objOS, tmZone
    Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
    Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOS in colOSes
        tmZone = objOS.CurrentTimeZone
    Next
    intUnixTime = intUnixTime + tmZone * 60
    convertDateTime = DateAdd("s", intUnixTime, "1970-1-1 00:00:00")
End Function

Sub syncDateTime(ByVal strNewDateTime, strOldDateTime)
    Dim ss, objDateTime, dtmNewDateTime
    ss = DateDiff("s", strOldDateTime, strNewDateTime)
    If Abs(ss) < 1 Then
        MsgBox "本机时间非常准确无需校对！"
        Exit Sub
    End If

    Set objDateTime = CreateObject("WbemScripting.SWbemDateTime")
    objDateTime.SetVarDate strNewDateTime, true 
    dtmNewDateTime = objDateTime.Value

    Dim objWMI, colOSes, objOS
    Set objWMI = GetObject("winmgmts:{(Systemtime)}\\.\root\cimv2")
    Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOS in colOSes
        objOS.SetDateTime dtmNewDateTime
    Next
    MsgBox "校准前：" & strOldDateTime & vbLf & "校准后：" & Now()
End Sub

Sub runAsAdmin()
    Dim objWMI, colOSes, objOS, strVer
    Set objWMI = GetObject("winmgmts:\\.\root\cimv2") 
    Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOS in colOSes
        strVer = Split(objOS.Version, ".")(0)
    Next
    If CInt(strVer) >= 6 Then
        Dim objShell
        Set objShell = CreateObject("Shell.Application")
        If WScript.Arguments.Count = 0 Then
            objShell.ShellExecute "WScript.exe", _
                """" & WScript.ScriptFullName & """ OK", , "runAs", 1
            Set objShell = Nothing
            WScript.Quit
        End If
    End If
End Sub
复制代码