标题: [问题求助] [已解决]vbs如何获取指定网页上的日期时间并同步到本机,若获取不到则不校准? [打印本页]
作者: ygqiang 时间: 2015-1-21 19:09 标题: [已解决]vbs如何获取指定网页上的日期时间并同步到本机,若获取不到则不校准?
本帖最后由 pcl_test 于 2016-6-6 22:51 编辑
[已解决]外网环境下,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 时间: 2015-1-21 19:12
另一个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 时间: 2015-1-21 19:30
有人说:
“可以用Msxml2.ServerXMLHTTP
获取一个固定的来自网络的字符 如果没有网络返回的是空值”
作者: yu2n 时间: 2015-1-21 21:52
本帖最后由 yu2n 于 2015-1-21 22:17 编辑
#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 时间: 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代码,初步测试成功。。。
不过还需要长时间的验证。- @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 时间: 2016-6-9 17:41
回复 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 时间: 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系统环境下,就出错。- @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
复制代码
欢迎光临 批处理之家 (http://www.bathome.net/) |
Powered by Discuz! 7.2 |