[问题求助] [已解决]vbs如何获取指定网页上的日期时间并同步到本机，若获取不到则不校准？

ygqiang

[已解决]外网环境下，bat+vbs，同步本机日期时间。若网络不通，直接退出而不校准。

否则，如何网络不通，继续校准后的日期时间，会是错误的。

call runAsAdmin()
On Error Resume Next
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)
On Error Resume Next
    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)
On Error Resume Next
    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()
On Error Resume Next
    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
复制代码

ygqiang

另一个vbs代码。也需要修改。

'VBS校准系统时间 BY BatMan
On Error Resume Next
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)
  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
复制代码

ygqiang

有人说：
“可以用Msxml2.ServerXMLHTTP
获取一个固定的来自网络的字符  如果没有网络返回的是空值”

ygqiang

回复 4# yu2n


  多谢。。测试通过。

ygqiang

回复 8# 9zhmke

以前通过baidu网址更新本地时间的vbs代码，都失效了。。


    下面的bat+vbs代码，初步测试成功。。。
不过还需要长时间的验证。

@echo off&setlocal enabledelayedexpansion

if "%1" == "h" goto begin
mshta vbscript:createobject("wscript.shell").run("%~fs0 h",0)(window.close)&&exit
:begin
rem 下边开始写批处代码了


ping 127.0.0.1 -n 5 >nul 2>nul

title 获取网络时间，同步到本机(需联网)
cd /d "%tmp%"
(
    echo With CreateObject("Microsoft.XMLHTTP"^)
    echo    .open "GET", "http://time.tianqi.com/", False
    echo    .send
    echo    s = Split(Split(.responseText, "new Date(("^)(1^), "+"^)(0^)
    echo End With
    echo WSH.Echo DateAdd("s", s * 1, "1970-1-1 8:00"^)
)>getTime.vbs


——————————————————————————
cls
for /l %%m in (1,1,180) do (

ping 127.0.0.1 -n 10 >nul 2>nul

ping time.tianqi.com -n 1 >nul 2>nul 

echo !errorlevel!
if !errorlevel! equ 0 goto :neta

echo 外网不通
)

echo 外网不通，持续30分钟

exit


:neta
echo 外网通，同步本机时间
for /f "tokens=1*" %%i in ('cscript //nologo gettime.vbs') do date %%i & time %%j
echo 本机系统时间设置完成！


exit
复制代码

ygqiang

回复 8# 9zhmke


    http://open.baidu.com/special/time

这个网址一直打不开，如何同步修改本地时间？？

ygqiang

回复 10# codegay


    换个别的能用的网址。那相关的vbs代码，就需要修改下吧？

ygqiang

回复 4# yu2n


    请教下。下面的代码。xp系统下时间同步正常。win7系统环境下，就出错。

@echo off
(
    echo;With CreateObject("Microsoft.XMLHTTP"^)
    echo;   .open "GET", "http://www.114time.com/api/time.php", False
    echo;   .send
    echo;   ms = .responseText*1
    echo;End With
    echo;WSH.Echo DateAdd("s", left(ms, len(ms^)-3^)+480*60, "1970-1-1 0:0:0"^)
)>%tmp%\dt.vbs
for /f "tokens=1*" %%i in ('cscript -nologo %tmp%\dt.vbs') do echo;date %%i&echo;time %%j
for /f "tokens=1*" %%i in ('cscript -nologo %tmp%\dt.vbs') do date %%i&time %%j
pause
复制代码

问题解决。。。

——————————————————————————————————————————————————————————
ver|find "XP" >nul&&goto :commo||goto :bootmgr

ver|find "5.2" >nul&&goto :commo||goto :bootmgr

if not exist c:\boot.ini goto :bootmgr


———————————————————————————————
:bootmgr

reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sDate" /t REG_SZ /d "/"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sLongDate" /t REG_SZ /d "yyyy'年'M'月'd'日'"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sShortDate" /t REG_SZ /d "yyyy/M/d"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sTime" /t REG_SZ /d ":"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sTimeFormat" /t REG_SZ /d "H:mm:ss"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sShortTime" /t REG_SZ /d "H:mm"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sYearMonth" /t REG_SZ /d "yyyy'年'M'月'"
reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "iFirstDayOfWeek" /t REG_SZ /d "0"

1pause




———————————————————————————————
:commo
复制代码