[问题求助] [已解决]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
获取一个固定的来自网络的字符  如果没有网络返回的是空值”

yu2n

#1F
Line 6

Function getBaiduTime()
  On Error Resume Next
  Dim strUrl, strText
  strUrl = "http://open.baidu.com/special/time/"
  With CreateObject("MSXML2.XmlHttp")
    .Open "GET", strUrl, False
    .Send()
    strText = CStr(.responseText)
  End With
  If Err.Number <> 0 Or InStr(strText,"window.baidu_time(")<1 Then
    Msgbox "Error.getBaiduTime() 无法获取在线时间数据。"
    WScript.Quit
  End If
  strText = Split(LCase(strText), "window.baidu_time(")(1)
  getBaiduTime = Int(Left(strText, 13)/1000)
End Function
复制代码

#2F
Line 19

regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
If regNum = "" Or regNum = 0 Then
  Msgbox "无法获取在线时间数据。"
  WScript.Quit
End If
复制代码

Self testing.

ygqiang

回复 4# yu2n


  多谢。。测试通过。

9zhmke

我自己也写过这个脚本，但发现好几个时间采集点经常出错自己的时间都不正确，你们遇到了吗？

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
复制代码

9zhmke

回复 7# ygqiang

batman的作品可以使用，只是偶尔会出现源时间不准的现象，与程序无关

if getset("网络校时")="1" then
        if ping("baidu.com")<888 then
            debug("已完成网络校时：" & Set_Net_DateTime() ) '根据网络设置正确时间
        else
            debug ("网络似乎没有通，无法校时")
       end if
end if


Function Set_Net_DateTime()'网络校时，批处理之家batman作品
    Dim objXML, Url, objStr, LocalDate,objREG, regNum,OldDate, BJDate, Num, Num1,DM, DT, TM, objSHELL,Arr, Arr1, h24
    Set_Net_DateTime= "本机时间非常准确无需校对."
    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
    objStr = objXML.responseText
    LocalDate = Now()
    Set objXML = Nothing
    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
    OldDate = "1970-01-01 08:00:00"
    BJDate = DateAdd("s", regNum, OldDate)
    Num = DateDiff("s", LocalDate, BJDate)
    If Abs(Num) >=1 Then
        DM = DateAdd("S", Num, Now())
        DT = DateValue(left(DM,instr(DM," ")))
        tmp3=trim(left(DT,instr(DT," ")))
        if tmp3 > "" then DT=tmp3
        TM = right(DM,len(DM)-InstrRev(DM," "))
        if len(TM)<4 then tmp3=trim(left(DM,InstrRev(DM,TM)-1)):TM=right(tmp3,len(tmp3)-InstrRev(tmp3," "))& " " & TM
        TM=TimeValue(TM)
        If InStr(Now, "午") Then
            Arr = Split(TM, " ")
            Arr1 = Split(Arr(1), ":")
            h24 = Arr1(0)
            If Arr(0) = "下午" Then
                h24 = h24 + 12
                if h24=24 then 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 /c date " & DT, 0, True
        objSHELL.Run "cmd /c time " & TM, 0, True
        Num1 = Abs(DateDiff("s", Now(), BJDate))
Set_Net_DateTime = "本机" & LocalDate & vbTab & "与标准时间" & BJDate & vbTab & "相差:" & vbTab & Abs(Num) & "秒"
        Set objSHELL = Nothing
    End If
End Function
复制代码

ygqiang

回复 8# 9zhmke


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

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

codegay

回复 9# ygqiang


    人是活的。不会换个别的能用的网址？

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
复制代码