程序代码 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
已有评论: