Board logo

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

作者: ygqiang    时间: 2015-1-21 19:09     标题: [已解决]vbs如何获取指定网页上的日期时间并同步到本机,若获取不到则不校准?

本帖最后由 pcl_test 于 2016-6-6 22:51 编辑

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

否则,如何网络不通,继续校准后的日期时间,会是错误的。
  1. call runAsAdmin()
  2. On Error Resume Next
  3. strNewDateTime = convertDateTime(getBaiduTime())
  4. call syncDateTime(strNewDateTime, Now())
  5. Function getBaiduTime()
  6.     Dim strUrl, strText
  7.     strUrl = "http://open.baidu.com/special/time/"
  8.     With CreateObject("MSXML2.XmlHttp")
  9.         .Open "GET", strUrl, False
  10.         .Send()
  11.         strText = .responseText
  12.     End With
  13.     strText = Split(LCase(strText), "window.baidu_time(")(1)
  14.     getBaiduTime = Int(Left(strText, 13)/1000)
  15. End Function
  16. Function convertDateTime(intUnixTime)
  17. On Error Resume Next
  18.     Dim objWMI, colOSes, objOS, tmZone
  19.     Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
  20.     Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
  21.     For Each objOS in colOSes
  22.         tmZone = objOS.CurrentTimeZone
  23.     Next
  24.     intUnixTime = intUnixTime + tmZone * 60
  25.     convertDateTime = DateAdd("s", intUnixTime, "1970-1-1 00:00:00")
  26. End Function
  27. Sub syncDateTime(ByVal strNewDateTime, strOldDateTime)
  28. On Error Resume Next
  29.     Dim ss, objDateTime, dtmNewDateTime
  30.     ss = DateDiff("s", strOldDateTime, strNewDateTime)
  31.     If Abs(ss) < 1 Then
  32.         'MsgBox "本机时间非常准确无需校对!"
  33.         Exit Sub
  34.     End If
  35.     Set objDateTime = CreateObject("WbemScripting.SWbemDateTime")
  36.     objDateTime.SetVarDate strNewDateTime, true
  37.     dtmNewDateTime = objDateTime.Value
  38.     Dim objWMI, colOSes, objOS
  39.     Set objWMI = GetObject("winmgmts:{(Systemtime)}\\.\root\cimv2")
  40.     Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
  41.     For Each objOS in colOSes
  42.         objOS.SetDateTime dtmNewDateTime
  43.     Next
  44.     'MsgBox "校准前:" & strOldDateTime & vbLf & "校准后:" & Now()
  45. End Sub
  46. Sub runAsAdmin()
  47. On Error Resume Next
  48.     Dim objWMI, colOSes, objOS, strVer
  49.     Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
  50.     Set colOSes =objWMI.ExecQuery("Select * from Win32_OperatingSystem")
  51.     For Each objOS in colOSes
  52.         strVer = Split(objOS.Version, ".")(0)
  53.     Next
  54.     If CInt(strVer) >= 6 Then
  55.         Dim objShell
  56.         Set objShell = CreateObject("Shell.Application")
  57.         If WScript.Arguments.Count = 0 Then
  58.             objShell.ShellExecute "WScript.exe", _
  59.                 """" & WScript.ScriptFullName & """ OK", , "runAs", 1
  60.             Set objShell = Nothing
  61.             WScript.Quit
  62.         End If
  63.     End If
  64. End Sub
复制代码

作者: ygqiang    时间: 2015-1-21 19:12

另一个vbs代码。也需要修改。
  1. 'VBS校准系统时间 BY BatMan
  2. On Error Resume Next
  3. Dim objXML, Url, Message
  4. 'Message = "恭喜你,本机时间非常准确无需校对!"
  5. Set objXML = CreateObject("MSXML2.XmlHttp")
  6. Url = "http://open.baidu.com/special/time/"
  7. objXML.open "GET", Url, False
  8. objXML.send()
  9. Do Until objXML.readyState = 4 : Wscript.Sleep 200 : Loop
  10. Dim objStr, LocalDate
  11. objStr = objXML.responseText
  12. LocalDate = Now()
  13. Set objXML = Nothing
  14. Dim objREG, regNum
  15. Set objREG = New RegExp
  16. objREG.Global = True
  17. objREG.IgnoreCase = True
  18. objREG.Pattern = "window.baidu_time\((\d{13,})\)"
  19. regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
  20. Dim OldDate, BJDate, Num, Num1
  21. OldDate = "1970-01-01 08:00:00"
  22. BJDate = DateAdd("s", regNum, OldDate)
  23. Num = DateDiff("s", LocalDate, BJDate)
  24. If Abs(Num) >=1 Then
  25.   Dim DM, y, M, D, H, MI, S, NewDateTime
  26.   DM = DateAdd("S", Num, Now())
  27.   y = Year(DM)
  28.   M = Right(0 & Month(DM), 2)
  29.   D = Right(0 & Day(DM), 2)
  30.   H = Right(0 & Hour(DM), 2)
  31.   MI = Right(0 & Minute(DM), 2)
  32.   S = Right(0 & Second(DM), 2)
  33.   NewDateTime = y & M & D & H & MI & S & ".000000+480"
  34.   Dim objWMI, objItems, objItem
  35.   Set objWMI = GetObject("winmgmts:{(systemtime)}!\\.\Root\Cimv2")
  36.   Set objItems = objWMI.ExecQuery("Select * From Win32_OperatingSystem")
  37.   For Each objItem In objItems
  38.     objItem.SetDateTime NewDateTime
  39.   Next
  40.   Set objWMI = Nothing
  41.   Num1 = Abs(DateDiff("s", Now(), BJDate))
  42. '   Message = "【校准前】" & vbCrLf _
  43. '    & "标准北京时间为:" & vbTab & BJDate & vbCrLf _
  44. '    & "本机系统时间为:" & vbTab & LocalDate & vbCrLf _
  45. '    & "与标准时间相差:" & vbTab & Abs(Num) & "秒" & vbCrLf & vbCrLf _
  46. '    & "【校准后】" & vbCrLf _
  47. '    & "本机系统时间为:" & vbTab & Now() & vbCrLf _
  48. '    & "与标准时间相差:" & vbTab & Num1 & "秒"
  49.   Set objSHELL = Nothing
  50. End If
  51. 'Wscript.Echo Message
复制代码

作者: ygqiang    时间: 2015-1-21 19:30

有人说:
“可以用Msxml2.ServerXMLHTTP
获取一个固定的来自网络的字符  如果没有网络返回的是空值”
作者: yu2n    时间: 2015-1-21 21:52

本帖最后由 yu2n 于 2015-1-21 22:17 编辑

#1F
Line 6
  1. Function getBaiduTime()
  2.   On Error Resume Next
  3.   Dim strUrl, strText
  4.   strUrl = "http://open.baidu.com/special/time/"
  5.   With CreateObject("MSXML2.XmlHttp")
  6.     .Open "GET", strUrl, False
  7.     .Send()
  8.     strText = CStr(.responseText)
  9.   End With
  10.   If Err.Number <> 0 Or InStr(strText,"window.baidu_time(")<1 Then
  11.     Msgbox "Error.getBaiduTime() 无法获取在线时间数据。"
  12.     WScript.Quit
  13.   End If
  14.   strText = Split(LCase(strText), "window.baidu_time(")(1)
  15.   getBaiduTime = Int(Left(strText, 13)/1000)
  16. End Function
复制代码
#2F
Line 19
  1. regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
  2. If regNum = "" Or regNum = 0 Then
  3.   Msgbox "无法获取在线时间数据。"
  4.   WScript.Quit
  5. End If
复制代码
Self testing.
作者: ygqiang    时间: 2015-1-21 22:34

本帖最后由 pcl_test 于 2016-6-6 22:47 编辑

回复 4# yu2n


  多谢。。测试通过。
作者: 9zhmke    时间: 2015-1-25 00:29

我自己也写过这个脚本,但发现好几个时间采集点经常出错自己的时间都不正确,你们遇到了吗?
作者: ygqiang    时间: 2016-6-6 22:18

本帖最后由 ygqiang 于 2016-6-6 22:26 编辑

回复 8# 9zhmke

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


    下面的bat+vbs代码,初步测试成功。。。
不过还需要长时间的验证。
  1. @echo off&setlocal enabledelayedexpansion
  2. if "%1" == "h" goto begin
  3. mshta vbscript:createobject("wscript.shell").run("%~fs0 h",0)(window.close)&&exit
  4. :begin
  5. rem 下边开始写批处代码了
  6. ping 127.0.0.1 -n 5 >nul 2>nul
  7. title 获取网络时间,同步到本机(需联网)
  8. cd /d "%tmp%"
  9. (
  10.     echo With CreateObject("Microsoft.XMLHTTP"^)
  11.     echo    .open "GET", "http://time.tianqi.com/", False
  12.     echo    .send
  13.     echo    s = Split(Split(.responseText, "new Date(("^)(1^), "+"^)(0^)
  14.     echo End With
  15.     echo WSH.Echo DateAdd("s", s * 1, "1970-1-1 8:00"^)
  16. )>getTime.vbs
  17. ——————————————————————————
  18. cls
  19. for /l %%m in (1,1,180) do (
  20. ping 127.0.0.1 -n 10 >nul 2>nul
  21. ping time.tianqi.com -n 1 >nul 2>nul
  22. echo !errorlevel!
  23. if !errorlevel! equ 0 goto :neta
  24. echo 外网不通
  25. )
  26. echo 外网不通,持续30分钟
  27. exit
  28. :neta
  29. echo 外网通,同步本机时间
  30. for /f "tokens=1*" %%i in ('cscript //nologo gettime.vbs') do date %%i & time %%j
  31. echo 本机系统时间设置完成!
  32. exit
复制代码

作者: 9zhmke    时间: 2016-6-9 17:41

回复 7# ygqiang

batman的作品可以使用,只是偶尔会出现源时间不准的现象,与程序无关
  1. if getset("网络校时")="1" then
  2.         if ping("baidu.com")<888 then
  3.             debug("已完成网络校时:" & Set_Net_DateTime() ) '根据网络设置正确时间
  4.         else
  5.             debug ("网络似乎没有通,无法校时")
  6.        end if
  7. end if
  8. Function Set_Net_DateTime()'网络校时,批处理之家batman作品
  9.     Dim objXML, Url, objStr, LocalDate,objREG, regNum,OldDate, BJDate, Num, Num1,DM, DT, TM, objSHELL,Arr, Arr1, h24
  10.     Set_Net_DateTime= "本机时间非常准确无需校对."
  11.     Set objXML = CreateObject("MSXML2.XmlHttp")
  12.     Url = "http://open.baidu.com/special/time/"
  13.     objXML.open "GET", Url, False
  14.     objXML.send()
  15.     Do Until objXML.readyState = 4 : WScript.Sleep 200 : Loop
  16.     objStr = objXML.responseText
  17.     LocalDate = Now()
  18.     Set objXML = Nothing
  19.     Set objREG = New RegExp
  20.     objREG.Global = True
  21.     objREG.IgnoreCase = True
  22.     objREG.Pattern = "window.baidu_time\((\d{13,})\)"
  23.     regNum = Int(objREG.Execute(objStr)(0).Submatches(0)) /1000
  24.     OldDate = "1970-01-01 08:00:00"
  25.     BJDate = DateAdd("s", regNum, OldDate)
  26.     Num = DateDiff("s", LocalDate, BJDate)
  27.     If Abs(Num) >=1 Then
  28.         DM = DateAdd("S", Num, Now())
  29.         DT = DateValue(left(DM,instr(DM," ")))
  30.         tmp3=trim(left(DT,instr(DT," ")))
  31.         if tmp3 > "" then DT=tmp3
  32.         TM = right(DM,len(DM)-InstrRev(DM," "))
  33.         if len(TM)<4 then tmp3=trim(left(DM,InstrRev(DM,TM)-1)):TM=right(tmp3,len(tmp3)-InstrRev(tmp3," "))& " " & TM
  34.         TM=TimeValue(TM)
  35.         If InStr(Now, "午") Then
  36.             Arr = Split(TM, " ")
  37.             Arr1 = Split(Arr(1), ":")
  38.             h24 = Arr1(0)
  39.             If Arr(0) = "下午" Then
  40.                 h24 = h24 + 12
  41.                 if h24=24 then h24=12
  42.             Else
  43.                 If h24 = 12 Then h24 = 0
  44.             End If
  45.             TM = h24 & ":" & Arr1(1) & ":" & Arr1(2)
  46.         End If
  47.         Set objSHELL = CreateObject("Wscript.Shell")
  48.         objSHELL.Run "cmd /c date " & DT, 0, True
  49.         objSHELL.Run "cmd /c time " & TM, 0, True
  50.         Num1 = Abs(DateDiff("s", Now(), BJDate))
  51. Set_Net_DateTime = "本机" & LocalDate & vbTab & "与标准时间" & BJDate & vbTab & "相差:" & vbTab & Abs(Num) & "秒"
  52.         Set objSHELL = Nothing
  53.     End If
  54. End Function
复制代码

作者: ygqiang    时间: 2016-6-9 18:27

回复 8# 9zhmke


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

这个网址一直打不开,如何同步修改本地时间??
作者: codegay    时间: 2016-6-9 22:29

回复 9# ygqiang


    人是活的。不会换个别的能用的网址?
作者: ygqiang    时间: 2016-6-11 16:19

回复 10# codegay


    换个别的能用的网址。那相关的vbs代码,就需要修改下吧?
作者: ygqiang    时间: 2017-4-25 15:15

本帖最后由 ygqiang 于 2017-4-25 17:17 编辑

回复 4# yu2n


    请教下。下面的代码。xp系统下时间同步正常。win7系统环境下,就出错。
  1. @echo off
  2. (
  3.     echo;With CreateObject("Microsoft.XMLHTTP"^)
  4.     echo;   .open "GET", "http://www.114time.com/api/time.php", False
  5.     echo;   .send
  6.     echo;   ms = .responseText*1
  7.     echo;End With
  8.     echo;WSH.Echo DateAdd("s", left(ms, len(ms^)-3^)+480*60, "1970-1-1 0:0:0"^)
  9. )>%tmp%\dt.vbs
  10. for /f "tokens=1*" %%i in ('cscript -nologo %tmp%\dt.vbs') do echo;date %%i&echo;time %%j
  11. for /f "tokens=1*" %%i in ('cscript -nologo %tmp%\dt.vbs') do date %%i&time %%j
  12. pause
复制代码
问题解决。。。
  1. ——————————————————————————————————————————————————————————
  2. ver|find "XP" >nul&&goto :commo||goto :bootmgr
  3. ver|find "5.2" >nul&&goto :commo||goto :bootmgr
  4. if not exist c:\boot.ini goto :bootmgr
  5. ———————————————————————————————
  6. :bootmgr
  7. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sDate" /t REG_SZ /d "/"
  8. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sLongDate" /t REG_SZ /d "yyyy'年'M'月'd'日'"
  9. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sShortDate" /t REG_SZ /d "yyyy/M/d"
  10. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sTime" /t REG_SZ /d ":"
  11. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sTimeFormat" /t REG_SZ /d "H:mm:ss"
  12. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sShortTime" /t REG_SZ /d "H:mm"
  13. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "sYearMonth" /t REG_SZ /d "yyyy'年'M'月'"
  14. reg add "HKEY_CURRENT_USER\Control Panel\International" /f /v "iFirstDayOfWeek" /t REG_SZ /d "0"
  15. 1pause
  16. ———————————————————————————————
  17. :commo
复制代码





欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2