B + Winsock + CGI 实现 QQ (OICQ) 在线检测(支持代理服务器)!
标准 EXE 例程下载
http://microinfo.top263.net/Zip/WskQQExe.zip

'请先 "引用" -> "浏览" -> "Windows 目录\SYSTEM\MSWINSCK.OCX"
Option Explicit
Dim sResponse As String
Dim WithEvents WinsockX As MSWinsockLib.Winsock
Dim WithEvents WinsockListenX As MSWinsockLib.Winsock
Private Sub Check1_Click()
Text2.Enabled = VBA.IIf(Check1.Value = vbChecked, True, False)
Text3.Enabled = Text2.Enabled
End Sub
Private Sub Check2_Click()
If Check2.Value = vbChecked Then
   Text4.Enabled = False
   WinsockListenX.Protocol = sckTCPProtocol
   WinsockListenX.LocalPort = CInt(Text4.Text)
   WinsockListenX.Listen
Else
   Text4.Enabled = True
   If WinsockX.State <> sckClosed Then
      WinsockX.Close
   End If
   If WinsockListenX.State <> sckClosed Then
      WinsockListenX.Close
   End If
End If
End Sub
Private Sub Command1_Click()
sResponse = ""
Command1.Enabled = False
Me.MousePointer = vbHourglass
Dim i As Long
If WinsockX.State <> sckClosed Then
   WinsockX.Close
End If
WinsockX.Protocol = sckTCPProtocol
If Check1.Value = vbChecked Then
   WinsockX.Connect Trim(Text2.Text), CInt(Text3.Text)
Else
   WinsockX.Connect "search.tencent.com", 80
End If
Do Until WinsockX.State = sckConnected
   DoEvents
   i = i + 1
   If i > 50000 Then
      If VBA.MsgBox("TimeOut,Retry?", vbQuestion + vbYesNo) = vbYes Then
         i = 0
      Else
         Command1.Enabled = True
         Me.MousePointer = vbDefault
         Exit Sub
      End If
   End If
Loop
WinsockX.SendData "POST " & VBA.IIf(Check1.Value = vbChecked, "HTTP://search.tencent.com", "") & "/cgi-bin/friend/oicq_find HTTP/1.1" & vbCrLf _
                & "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-excel, application/msword, application/vnd.ms-powerpoint, */*" & vbCrLf _
                & "Accept -Language: zh -cn" & vbCrLf _
                & "Content-Type: application/x-www-form-urlencoded" & vbCrLf _
                & "Accept -Encoding: gzip , deflate" & vbCrLf _
                & "User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; Win 9x 4.90)" & vbCrLf _
                & "Host: " & WinsockX.RemoteHost & vbCrLf _
                & "Content-Length: " & VBA.Len(VBA.Trim("oicq_no=" & VBA.Trim(Text1.Text) & "&mov=0&begnum=0")) & vbCrLf _
                & "Connection: Keep -Alive" & vbCrLf _
                & "Cookie: 3wave=1" & vbCrLf & vbCrLf _
                & "oicq_no=" & VBA.Trim(Text1.Text) & "&mov=0&begnum=0"
End Sub
Private Sub Form_Load()
Text1.Text = "6881818"
Text2.Text = "192.168.0.1"
Text3.Text = "8080"
Text4.Text = "80"
Set WinsockX = New MSWinsockLib.Winsock
Set WinsockListenX = New MSWinsockLib.Winsock
Check1_Click
Check2_Click
End Sub
Private Sub WinsockListenX_ConnectionRequest(ByVal requestID As Long)
If WinsockX.State <> sckClosed Then
   WinsockX.Close
End If
WinsockX.Accept requestID
End Sub
Private Sub WinsockX_Close()
Command1.Enabled = True
Me.MousePointer = vbDefault
If sResponse Like "*http://img.tencent.com/face/*-3.gif*" Then
   MsgBox "Off line!"
ElseIf sResponse Like "*http://img.tencent.com/face/*-2.gif*" Then
   MsgBox "On line!"
ElseIf sResponse Like "*http://img.tencent.com/face/*-1.gif*" Then
   MsgBox "Hide!"
End If
End Sub
Private Sub WinsockX_DataArrival(ByVal bytesTotal As Long)
Dim s As String
WinsockX.GetData s, vbString
If Check2.Value = vbChecked Then
   MsgBox s
End If
sResponse = sResponse & s
End Sub

ActiveX DLL 例程下载:
http://microinfo.top263.net/Zip/WskQQDll.zip