[原创]检测阿里旺旺用户是否在线

Question

Option Explicit
'===========================================================================
'//功能:检测阿里旺旺用户是否在线
'//用法:MsgBox AliWangOnLine("阿里旺旺ID了")    True在线   False不在线
'//作者:[email protected]村姑     转载请注名出处! http://hi.baidu.com/countrygril/
'===========================================================================
Private Declare Function GetUrlCacheEntryInfo Lib "wininet.dll" Alias "GetUrlCacheEntryInfoA" (ByVal sUrlName As String, lpCacheEntryInfo As Any, lpdwCacheEntryInfoBufferSize As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Public Function AliWangOnLine(ByVal sUserNameID As String) As Boolean
    Dim strID As String
    strID = "http://amos1.taobao.com/muliuserstatus.aw?beginnum=0&site=cntaobao&uids=" & sUserNameID
    Call DeleteCacheURL(strID)
    If InStr(GetHTML(strID), "1") <> 0 Then
        AliWangOnLine = True
    Else
        AliWangOnLine = False
    End If
End Function
Private Function InCache(ByVal URL As String) As Boolean
    If GetUrlCacheEntryInfo(URL, ByVal 0&, 0) = 0 Then
        InCache = (Err.LastDllError = 122)
    End If
End Function
Private Sub DeleteCacheURL(ByVal URL As String)
If (InCache(URL)) Then
    DeleteUrlCacheEntry URL
End If
End Sub
Private Function GetHTML(sURL) As String
    Dim XMLHTTP As Object, ReturnType As String
    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
    If Not IsObject(XMLHTTP) Then
        Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
        If Not IsObject(XMLHTTP) Then Exit Function
    End If
    XMLHTTP.Open "GET", sURL, True
    XMLHTTP.Send
    Do While XMLHTTP.readystate <> 4
        DoEvents
    Loop
    GetHTML = StrConv(XMLHTTP.ResponseBody, vbUnicode)
End Function