以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  [求助]这段获取网络时间的代码在Foxtable中怎样应用?  (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=27052)

--  作者:blueskyyq
--  发布时间:2012/12/20 17:56:00
--  [求助]这段获取网络时间的代码在Foxtable中怎样应用?

大家帮忙看看这段获取网络时间的VB代码在Foxtable中怎么用?

 

Private Sub Command1_Click()
Dim obj, OBJStatus, url, GetText, i
Dim Retrieval
    url = "http://www.baidu.com"
    \'判断网络是否连接
    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")
    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
End Sub

 

[此贴子已经被作者于2012-12-20 18:27:40编辑过]

--  作者:狐狸爸爸
--  发布时间:2012/12/20 18:22:00
--  

获取国际标准时间,记得考虑时差:

 

 下载信息  [文件大小:   下载次数: ]
图片点击可在新窗口打开查看点击浏览该文件:管理项目78.table

结果加上8小时,就是北京时间。

[此贴子已经被作者于2012-12-20 18:24:41编辑过]

--  作者:blueskyyq
--  发布时间:2012/12/20 18:24:00
--  
谢谢狐爸,参考下
--  作者:布莱克朱
--  发布时间:2012/12/20 19:14:00
--  
这段代码 有问题吧  你自己测试下

在全局代码中  拷贝进去

Public Function NewTime(ByVal p1 As Date) As Date
Dim obj, OBJStatus, url, GetText, i
Dim Retrieval
url = "http://www.baidu.com"
\'判断网络是否连接
If url <> "" Then
    Retrieval = GetObject("winmgmts:\\\\.\\root\\cimv2")
    obj = Retrieval.ExecQuery("Select * From Win32_PingStatus Where Address = \'" & Mid(url, 8) & "\'")
    For Each OBJStatus In obj
        If OBJStatus.StatusCode Is Nothing Or OBJStatus.StatusCode <> 0 Then
            Exit Function
        Else
            Exit For \'已连接则继续
        End If
    Next
End If

\'通过下载网页头信息获取网络时间
Retrieval = CreateObject("Microsoft.XMLHTTP")
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 Function
    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
Retrieval = Nothing
OBJStatus = Nothing
obj = Nothing
End Function



命令窗口
Dim d As Date
Output.Show(newTime(D))

 我出来的是 网络时间: 2012-12-20 11:13:37


--  作者:lin_hailun
--  发布时间:2012/12/20 19:26:00
--  
 好用,测试都有效,收藏一下。
--  作者:布莱克朱
--  发布时间:2012/12/20 19:31:00
--  
原来需要加上8  那这样改:

Public Function NewTime(ByVal p1 As Date) As Date
Dim obj, OBJStatus, url, GetText, i
Dim Retrieval
url = "http://www.baidu.com"
\'判断网络是否连接
If url <> "" Then
    Retrieval = GetObject("winmgmts:\\\\.\\root\\cimv2")
    obj = Retrieval.ExecQuery("Select * From Win32_PingStatus Where Address = \'" & Mid(url, 8) & "\'")
    For Each OBJStatus In obj
        If OBJStatus.StatusCode Is Nothing Or OBJStatus.StatusCode <> 0 Then
            Exit Function
        Else
            Exit For \'已连接则继续
        End If
    Next
End If

\'通过下载网页头信息获取网络时间
Retrieval = CreateObject("Microsoft.XMLHTTP")
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 Function
    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)
        Dim d As Date = GetText
        d =d.AddHours(8)
        MsgBox("网络时间:" & d)
        \'MsgBox("网络时间:" & GetText)
    End If
End With
Retrieval = Nothing
OBJStatus = Nothing
obj = Nothing
End Function


命令窗口:

Dim d As Date
newtime(d)

--  作者:布莱克朱
--  发布时间:2012/12/20 19:43:00
--  
老大自己给自己打个精华
--  作者:blueskyyq
--  发布时间:2012/12/20 19:56:00
--  

谢谢朱兄,精华!

狐爸别光顾着给自己精华啊,给朱兄也来个精


--  作者:e-png
--  发布时间:2012/12/20 19:59:00
--  
以下是引用布莱克朱在2012-12-20 19:43:00的发言:
老大自己给自己打个精华

呵呵,他说过精华是为引起重视,让人学习用。


--  作者:blueskyyq
--  发布时间:2012/12/20 20:02:00
--  
嗯,也能促进广大狐友答疑及分享的积极性