程序代码

Private Sub Command1_Click()
    Me.Caption = 获取北京时间()
End Sub
'==============================以上为调用方法==============================
'==============================以下为标准模块代码==============================
Public Function 获取北京时间() As String
    On Error GoTo 出错处理:
    Dim WinHttp As WinHttp.WinHttpRequest
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    WinHttp.Open "GET", "http://m.bjtime.cn/header10.asp", True
    WinHttp.SetTimeouts 5000, 5000, 5000, 5000
    WinHttp.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
    WinHttp.SetRequestHeader "Host", "m.bjtime.cn"
    WinHttp.SetRequestHeader "Connection", "keep-alive"
    WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 5.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/42.0.2311.135 Safari/537.36"
    WinHttp.SetRequestHeader "Accept", "*/*"
    WinHttp.SetRequestHeader "Referer", "http://m.bjtime.cn/"
    WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
    WinHttp.SetRequestHeader "Cookie", "visit=bjtime; ASPSESSIONIDCQDTCCRT=NKJOCKIDDBGFNKNOPJNJLMNP"
    WinHttp.Send
    WinHttp.WaitForResponse
    While WinHttp.Status <> 200
        DoEvents
    Wend
    获取北京时间 = BytesToBstr(WinHttp.ResponseBody, "UTF-8")
    Set WinHttp = Nothing
    获取北京时间 = FromUnixTime(Left(Shijian, 10), 8)
    Exit Function
出错处理:
    Set WinHttp = Nothing
    获取北京时间 = "获取失败！"
End Function
Public Function BytesToBstr(strBody, CodeBase)
    Dim ObjStream
    Set ObjStream = CreateObject("Adodb.Stream")
    With ObjStream
        .Type = 1
        .Mode = 3
        .Open
        .Write strBody
        .Position = 0
        .Type = 2
        .Charset = CodeBase
        BytesToBstr = .ReadText
        .Close
    End With
    Set ObjStream = Nothing
End Function
Function FromUnixTime(intTime, intTimeZone)
    If IsEmpty(intTime) Or Not IsNumeric(intTime) Then
        FromUnixTime = Now()
        Exit Function
    End If
    If IsEmpty(intTime) Or Not IsNumeric(intTimeZone) Then intTimeZone = 0
    FromUnixTime = DateAdd("s", intTime, "1970-1-1 0:0:0")
    FromUnixTime = DateAdd("h", intTimeZone, FromUnixTime)
End Function