通过网络获取时间，

liucqa

昨天www.timeanddate.com有一阵子不好使，一发送objXML.sEnd就挂机，只好换了个网站，在原代码上重写了一个，国内的网站访问速度还是很快的。
原帖来自http://club.excelhome.net/thread-539047-1-1.html

Function GetInternetDate2() As Date
    On Error Resume Next
    Dim objXML As Object
    Dim strTemp As String
    Dim lStart As Long
    Dim lEnd As Long
    Dim DtWeb As Date

    DtWeb = #12/31/2010#                                                '设置默认返回时间

    '建立XMLHTTP对象。并获取网页Text
    Set objXML = CreateObject("Microsoft.XMLHTTP")
    objXML.Open "Get", "http://www.timedate.cn/worldclock/ti.asp", False   '读取时间日期网
    objXML.sEnd ""
    strTemp = objXML.responseText

    '对网页进行处理，找出当前日期和时间

    lStart = InStr(1, strTemp, "nsec=", vbTextCompare)
    lEnd = InStr(lStart, strTemp, ";", vbTextCompare)
    lStart = InStr(1, strTemp, "nyear=", vbTextCompare)
    strTemp = Mid(strTemp, lStart + 5, lEnd - lStart - 6)

    Dim nwday As String
    Dim i As Long
    Dim j As Long
    Dim str As String
    Dim c As String
    Dim asccode As Integer

    str = ""
    j = 0
    Debug.Print Timer
    For i = 1 To Len(strTemp)
        c = Mid(strTemp, i, 1)
        If c = "=" Then j = j + 1
        If j <> 4 Then
            asccode = Asc(c)
            If asccode >= 48 And asccode <= 57 Then str = str & c
        End If
        If c = ";" Then
            If j < 3 Then str = str & "/"
            If j = 4 Then str = str & " "
            If j = 5 Or j = 6 Then str = str & ":"
        End If
    Next
    Debug.Print Timer

    lStart = InStr(1, strTemp, "nwday=", vbTextCompare)
    lEnd = InStr(lStart, strTemp, ";", vbTextCompare)
    nwday = Mid(strTemp, lStart + 6, lEnd - lStart - 6)
    nwday = Choose(CInt(nwday), "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")

    DtWeb = CDate(str)

    Set objXML = Nothing

    GetInternetDate2 = DtWeb
End Function

www505

可否介绍一下作用。

liucqa

用F8跟踪一下不就明白了，我就是这么学习的

lotteryman

精典，好贴，顶一个。