Question

vb获取网络时间，然后修改本地时间

Dim t, bPrivate Sub Command1_Click()
Dim obj, OBJStatus, url, GetText, i
Dim Retrieval
url = "http://bjtime.cn/" '判断网络是否连接
If url <> "" Then
Set Retrieval = GetObject("winmgmts:\\.\root\cimv2")
Set obj = Retrieval.ExecQuery("Select * From Win32_PingStatus Where Address = '" & Mid(url, 8) & "'")
For Each OBJStatus In obj

If IsNull(OBJStatus.StatusCode) Or OBJStatus.StatusCode <> 0 Then
Exit Sub
Else: Exit For '已连接则继续
End If
Next
End If '通过下载网页头信息获取网络时间

Set Retrieval = CreateObject("Microsoft.XMLHTTP")
t = Time
b = Date
With Retrieval
.Open "Get", url, False, "", ""
.setRequestHeader "If-Modified-Since", "0"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Connection", "close"
.Send
If .ReadyState <> 4 Then Exit Sub
GetText = .getAllResponseHeaders()
i = InStr(1, GetText, "date:", vbTextCompare)
If i > 0 Then '网页下载成功
i = InStr(i, GetText, ",", vbTextCompare)

GetText = Trim(Mid(GetText, i + 1))
i = InStr(1, GetText, " GMT", vbTextCompare)
GetText = Left(GetText, i - 1)
MsgBox "网络时间:" & GetText
End If
End With
Set Retrieval = Nothing
Set OBJStatus = Nothing
Set obj = Nothing
Do
DoEvents
Date = b
Time = GetText
Loop Until Command1.Caption = "修改成功"

End Sub

获得的时间和真实的相差4小时，不知道为什么？要怎么改，或者更好的办法。

Answer 1

Private Sub Command1_Click()
On Error GoTo Err_Load

Dim StrCoding As String
    StrCoding = Inet1.OpenURL("http://www.time.ac.cn/stime.asp";)
    Debug.Print StrCoding
    Time0 = Right(Split(StrCoding, "年")(0), 4) & "年" & Split(Split(StrCoding, "年")(1), "日")(0) & "日"
    date0 = Left(Split(StrCoding, "var hrs = ")(1), 2) & ":" & Left(Split(StrCoding, "var min = ")(1), 2) & ":" & Left(Split(StrCoding, "var sec = ")(1), 2)
    Label1.Caption = "    中国地区标准时间：" & Time0 & " " & Format(date0, "hh时mm分ss秒")
    Label2.Caption = "        本机系统时间：" & Format(Date, "yyyy年m月d日") & " " & Format(Time, "hh时mm分ss秒")
   
    Date = CDate(Time0)
    Time = CDate(date0)
   
Exit Sub
Err_Load:
If Err.Number <> 0 Then
    Select Case Err.Number
    Case 9
        MsgBox "错误代码：" & Err.Number & "   错误描述：" & Err.Description, vbExclamation, "获取网络日期"
'        MsgBox "请检查您的网络连接，稍候再尝试这个操作！", vbExclamation, "获取网络日期"
        Exit Sub
    Case 364
        Resume Next
    Case Else
        MsgBox "错误代码：" & Err.Number & "   错误描述：" & Err.Description, vbExclamation, "获取网络日期"
    End Select
End If
End Sub

 

这是我做的比中科院相差0点几秒.

Answer 2

，用XMLHTTP随机访问一个网站可以采取的做法

Answer 3

问题是什么？