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 "* MsgBox "Off line!"
ElseIf sResponse Like "* MsgBox "On line!"
ElseIf sResponse Like "* 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