本帖最后由 ygqiang 于 2021-12-1 14:28 编辑
2021年。js和vbs代码可用:网络日期、网络时间,同步到本地电脑上。
感谢:Yu2n
系统环境:win7 64- 'VBS校准系统时间 BY Yu2n 2019.05.26
- 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
-
-
- '************************************************************************
- '获取网络上指定的HTTP服务器时间
- '************************************************************************
- Function GetNetTime(ByVal Url)
- Dim Bias, DateLine '时间偏移(分钟)
- Dim dtGMT, dtLocal, dtBegin
- On Error Resume Next
- With CreateObject("WScript.Shell")
- '[ActiveTimeBias]:该键值存储当前系统时间相对格林尼治标准时间的偏移(以分钟为单位)
- '[Bias]:该键值存储当前本地时间相对格林尼治标准时间的偏移(以分钟为单位)
- 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)) '北京时间:GMT+8
- 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
- 'WScript.Echo "警告:设置系统时间失败!"
- SetDateTime = False
- Else
- 'WScript.Echo "提示:设置成功。当前时间:" & DateTime.GetVarDate()
- SetDateTime = True
- End If
- Next
- End Function
-
-
- '************************************************************************
- '初始化 RunAsAdminX64 For Win10 x64
- '************************************************************************
- 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
- '获取 WSH 参数
- For Each vArg In WScript.Arguments
- sArgs = sArgs & " " & """" & vArg & """"
- Next
- '获取 32 位 WSH 目录
- 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
- '以 32 位 WSH 运行
- If UCase(WScript.FullName) <> UCase(sSD32 & "\" & sSFN) Then
- wso.Run sSD32 & "\" & sSFN & " """ & WScript.ScriptFullName & """" & sArgs, 1, False
- WScript.Quit
- End If
- '以管理员权限运行 WSH
- 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 Function
复制代码
|