我来改一下,不是因为lz所说的“无线网络不能用”,而是为了win7开启uac时双击能用,另外时区更改了不受影响 | 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 SubCOPY |
|