VBS校准系统时间

batman · 发表于 2013-1-10 00:49:28

本帖最后由 batman 于 2013-1-10 18:23 编辑

更新为自动判断时间格式，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

复制代码

czjt1234 · 发表于 2013-1-10 08:14:52

29行，下标越界

batman · 发表于 2013-1-10 11:53:50

回复 2# czjt1234

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

522235677 · 发表于 2013-1-10 14:11:53

本帖最后由 522235677 于 2013-1-10 14:13 编辑

以后就方便了，网上有的校准软件杀毒软件会报毒……

lxningbat · 发表于 2013-1-10 16:48:59

不错，不过可能由于程序的运行获取信息的延时显示会误差1到2秒

极品小猫 · 发表于 2013-1-10 16:50:42

一般系统默认都采用24小时制
这个东西好，每次用系统自身的更新系统时间都巨麻烦，更新前还必须调系统日期才能更新

batman · 发表于 2013-1-10 22:57:09

哼哼哈嘿！快使用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

复制代码

yu2n · 发表于 2013-1-11 01:01:29

建议加入 UNC 运行提醒。

JS版

<title>
EasyX v20120603(beta) 安装向导
</title>
<script type="text/javascript">
function GetSystemVersion() {
var os = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem");
for (var e = new Enumerator(os); ! e.atEnd(); e.moveNext()) {
var v = e.item().Version;
var ss = v.split('.');
return ss[0] + ss[1];
}
return - 1;
}
if (GetSystemVersion() >= 60) {
var cmd = location.pathname;
if (cmd.substring(cmd.length - 4) != ".HTA") {
var Shell = new ActiveXObject("Shell.Application");
Shell.ShellExecute("mshta.exe", """ + cmd.substring(0, cmd.length - 4) + ".HTA"", "", "runas", 1);
window.close();
exit(0);
}
}
</script>

复制代码

9zhmke · 发表于 2013-7-8 23:12:13

我也借鉴来写个：

Function Set_Net_DateTime()
  Dim attrib,day,month,year,hours
  'On Error Resume Next
  attrib=Split(getHTTPPage("http://stdtime.gov.hk:13"))'30 JAN 2012 00:04:42 HKT
  day=attrib(0)
  month=int(instr("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",attrib(1))/3)+1
  year=attrib(2)
  hours=attrib(3)
  Set objSWbemDateTime=CreateObject("WbemScripting.SWbemDateTime")
  objSWbemDateTime.SetVarDate year&"-"&month&"-"&day&" "&attrib(3),True '"2009-3-30 22:38:00"
  Set objWMIService=GetObject("winmgmts:{(Systemtime)}\\.\root\cimv2")
  Set colOSes=objWMIService.ExecQuery("Select * From Win32_OperatingSystem")
  For Each objOS In colOSes
objOS.SetDateTime objSWbemDateTime.Value
  Next
  Set objSWbemDateTime=nothing
  set objWMIService=nothing
  set colOSes=nothing
End Function

yu2n · 发表于 2015-11-8 22:27:19

本帖最后由 yu2n 于 2019-5-26 12:41 编辑

2019.05.26 已更新时间来源，可设置任意网站为时间源。 (自定义 HTTP 服务器可修改代码中的 http://www.microsoft.com )

Win7x64 / Win10x64 测试通过

'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

复制代码

Heykuz · 发表于 2015-11-9 22:00:26

都测试了，感谢七楼的版主，仅只测试通过。本人win7 64 网络下载微软官方正版。
感谢其它楼的，家中的老爷机子上通过。win7 64 俄罗斯高人精简版。

yu2n · 发表于 2017-2-10 23:38:55

本帖最后由 yu2n 于 2019-5-26 12:41 编辑

2019.05.26 已更新时间来源，可设置任意网站为时间源。 (自定义 HTTP 服务器可修改代码中的 http://www.microsoft.com )

Js 也来凑热闹了……

//文件名称：SyncNetTime2.js
//功能说明：同步本机时间与网络时间
//使用方法：Cscript.exe //nologo SyncNetTime.js
//测试环境：系统 Win10 x64 时间 18/1/15 用户 Yu2n
//更新内容：Fix 获取网络时间，从 HTTP SERVER HEADER
//以管理员运行
function GetSystemVersion() {
var os = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem");
for (var e = new Enumerator(os); ! e.atEnd(); e.moveNext()) {
var v = e.item().Version;
var ss = v.split('.');
return ss[0] + ss[1];
}
return - 1;
}
if (GetSystemVersion() >= 60) {
var cmd = WScript.ScriptFullName;
if (cmd.substring(cmd.length - 3) != ".jS") {
var Shell = new ActiveXObject("Shell.Application");
Shell.ShellExecute("wscript.exe", """ + cmd.substring(0, cmd.length - 3) + ".jS"", "", "runas", 1);
WScript.Quit(0);
}
}
//获取网络时间，从 HTTP SERVER HEADER
var getNetDate = function() {
var dtGMT = '';
try{
var http = new ActiveXObject("Microsoft.XMLHTTP");
http.open("POST", "http://www.microsoft.com?rnd=" + (new Date()), false);
http.send();
dtGMT = http.getResponseHeader("Date");
if (dtGMT != '') {
return new Date(dtGMT);
} else {
WScript.Echo("警告：获取网络时间失败！")
WScript.Quit(0);
};
}catch(e){};
};
//设置时间
function ChangeDate()
{
var WmiService, ComputerName, OSList, OSEnum, OS, DateTime;
ComputerName = ".";
WmiService = GetObject ("winmgmts:{impersonationLevel=impersonate, (Systemtime)}!//" + ComputerName + "/root/cimv2");
OSList = WmiService.InstancesOf ("Win32_OperatingSystem");
DateTime = new ActiveXObject ("WbemScripting.SWbemDateTime");
OSEnum = new Enumerator (OSList);
for ( ; !OSEnum.atEnd(); OSEnum.moveNext())
{
OS = OSEnum.item();
var dtNewDate = getNetDate(); //获取网络时间
DateTime.Value = OS.LocalDateTime;
DateTime.Year = dtNewDate.getFullYear();
DateTime.Month = dtNewDate.getMonth() + 1;
DateTime.Day = dtNewDate.getDate();
DateTime.Hours = dtNewDate.getHours();
DateTime.Minutes = dtNewDate.getMinutes();
DateTime.Seconds = dtNewDate.getSeconds();
if (OS.SetDateTime(DateTime.Value) != 0) {
WScript.Echo("警告：设置系统时间失败！");
} else {
WScript.Echo("提示：设置成功。当前时间：" + new Date(DateTime.GetVarDate()).toLocaleString());
};
}
}
ChangeDate();
WScript.Quit(0);

复制代码

citygun · 发表于 2019-4-24 13:24:11

本帖最后由 citygun 于 2019-4-24 13:51 编辑

Js 也来凑热闹了……
yu2n 发表于 2017-2-10 23:38

之前一直用这个，不过最近貌似服务器地址有变化就失效了。。。目前的地址是http://time1903.beijing-time.org/time.asp还可以用

yu2n · 发表于 2019-5-26 12:40:03

回复 13# citygun

已更新时间来源，可设置任意网站为时间源。

citygun · 发表于 2019-7-19 22:25:19

回复 14# yu2n

一直在用这个js，很方便好用，感谢你写这么好用的脚本！

		自动登录	找回密码
密码			注册

[新手上路]批处理新手入门导读	[视频教程]批处理基础视频教程	[视频教程]VBS基础视频教程	[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动	[批处理精品]CMD命令50条不能说的秘密	[在线下载]第三方命令行工具	[在线帮助]VBScript / JScript 在线参考

[原创] VBS校准系统时间

评分

浏览过的版块