| |
| Option Explicit |
| |
| RunAsAdminX64 |
| Main |
| |
| |
| Sub Main() |
| |
| Dim dtNet, dtLocal1, dtLocal2, lngOffset1, lngOffset2, strMessage |
| dtNet = GetNetTime("http://www.microsoft.com") |
| dtLocal1 = Now() |
| lngOffset1 = Abs(DateDiff("s", dtNet, dtLocal1)) |
| If lngOffset1 > 1 Then |
| SetDateTime dtNet |
| dtLocal2 = Now() |
| lngOffset2 = Abs(DateDiff("s", dtNet, dtLocal2)) |
| strMessage = "【校准前】" & vbCrLf _ |
| & "标准北京时间为:" & vbTab & dtNet & vbCrLf _ |
| & "本机系统时间为:" & vbTab & dtLocal1 & vbCrLf _ |
| & "与标准时间相差:" & vbTab & lngOffset1 & "秒" & vbCrLf & vbCrLf _ |
| & "【校准后】" & vbCrLf _ |
| & "标准北京时间为:" & vbTab & dtNet & vbCrLf _ |
| & "本机系统时间为:" & vbTab & dtLocal2 & vbCrLf _ |
| & "与标准时间相差:" & vbTab & lngOffset2 & "秒" |
| Else |
| strMessage = "【无需校准】" & vbCrLf _ |
| & "标准北京时间为:" & vbTab & dtNet & vbCrLf _ |
| & "本机系统时间为:" & vbTab & dtLocal1 & vbCrLf _ |
| & "与标准时间相差:" & vbTab & lngOffset1 & "秒" |
| End If |
| WScript.Echo strMessage |
| End Sub |
| |
| |
| |
| |
| |
| Function GetNetTime(ByVal Url) |
| Dim Bias, DateLine |
| Dim dtGMT, dtLocal, dtBegin |
| On Error Resume Next |
| With CreateObject("WScript.Shell") |
| |
| |
| Bias = .RegRead("HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias") |
| End With |
| With CreateObject("Microsoft.XMLHTTP") |
| dtBegin = Now() |
| .Open "POST", Url, False |
| .Send |
| If Err.Number = 0 Then |
| dtGMT = Split(Replace(.getResponseHeader("Date"), " GMT", ""), ",")(1) |
| If IsDate(dtGMT) Then |
| dtLocal = DateAdd("n", -CLng(Bias), CDate(dtGMT)) |
| dtLocal = DateAdd("s", DateDiff("s", dtBegin, Now()), dtLocal) |
| GetNetTime = dtLocal |
| End If |
| End If |
| End With |
| End Function |
| |
| |
| |
| |
| |
| Function SetDateTime(ByVal dt1) |
| Dim WmiService, ComputerName, OSList, OSEnum, OS, DateTime |
| ComputerName = "." |
| Set WmiService = GetObject("winmgmts:{impersonationLevel=impersonate, (Systemtime)}!//" + ComputerName + "/root/cimv2") |
| Set OSList = WmiService.InstancesOf ("Win32_OperatingSystem") |
| Set DateTime = CreateObject("WbemScripting.SWbemDateTime") |
| For Each OSEnum In OSList |
| DateTime.Value = OSEnum.LocalDateTime |
| DateTime.Year = Year(dt1) |
| DateTime.Month = Month(dt1) |
| DateTime.Day = Day(dt1) |
| DateTime.Hours = Hour(dt1) |
| DateTime.Minutes = Minute(dt1) |
| DateTime.Seconds = Second(dt1) |
| If (OSEnum.SetDateTime(DateTime.Value) <> 0) Then |
| |
| SetDateTime = False |
| Else |
| |
| SetDateTime = True |
| End If |
| Next |
| End Function |
| |
| |
| |
| |
| |
| Function RunAsAdminX64() |
| Dim wso, fso, dwx, sSFN, sSD32, sSF32, vArg, sArgs, oShell, sDWX |
| Set wso = CreateObject("WScript.Shell") |
| Set fso = CreateObject("Scripting.filesystemobject") |
| RunAsAdminX64 = False |
| |
| For Each vArg In WScript.Arguments |
| sArgs = sArgs & " " & """" & vArg & """" |
| Next |
| |
| sSFN = fso.GetFile(WScript.FullName).Name |
| sSD32 = wso.ExpandenVironmentStrings("%windir%\SysWOW64") |
| If Not fso.FileExists(sSD32 & "\" & sSFN ) Then |
| sSD32 = wso.ExpandenVironmentStrings("%windir%\System32") |
| End If |
| |
| If UCase(WScript.FullName) <> UCase(sSD32 & "\" & sSFN) Then |
| wso.Run sSD32 & "\" & sSFN & " """ & WScript.ScriptFullName & """" & sArgs, 1, False |
| WScript.Quit |
| End If |
| |
| If Not WScript.Arguments.Named.Exists("ADMIN") Then |
| Set oShell = CreateObject("Shell.Application") |
| oShell.ShellExecute WScript.FullName, """" & WScript.ScriptFullName & """ " & sArgs & " /ADMIN:1 ", "", "runas", 6 |
| WScript.Quit |
| End If |
| End FunctionCOPY |