300分 求转换VB一段代码，代码已帖出，有关QQ UDP协议的。 ( 积分: 300 )

小弟我写个QQ协议的，这里有个VB的挂机源代码。UDP的，但是VB看不懂，请大虾把主要的转换一下delphi的，最好用UdpSocket等写个例子。希望大虾帮帮小弟。

Attribute VB_Name = "OutPacket"
'头部:
'0 = 0x02
'1-2 = 客户端版本号码
'3-4 = 命令类型
'5-6 = 包序号 * <li>包序号, 0x05~0x06.
'7-10 = 用户 QQ 号 * <li>用户QQ号, 0x07~0x0A
'
'尾部: 0x03
Option Explicit

Public Function LoginToken(ByVal QQNum As Long) As Byte()
On Error Resume Next
Dim Packet(12) As Byte
Dim QQBuff(3) As Byte
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H62
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
Packet(11) = &H0 '请求登陆令牌
Packet(12) = &H3 '结尾
LoginToken = Packet
End Function

Public Function LoginPacket(ByVal QQNum As Long, ByVal QQHide As Boolean, LoginKey() As Byte, PasswordKey() As Byte, LoginToken() As Byte) As Byte()
On Error Resume Next
Dim Packet(459) As Byte, Plain(415) As Byte, Crypt() As Byte, QQBuff(3) As Byte, PasswordEncode() As Byte, Free() As Byte
Dim Tea As New clsTea
If UBound(LoginKey) <> 15 Then Exit Function
If UBound(PasswordKey) <> 15 Then Exit Function
If UBound(LoginToken) <> 23 Then Exit Function
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H22
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)

'初始密钥
CopyMemory Packet(11), LoginKey(0), 16

'密码密钥
PasswordEncode = Tea.Encrypt(Free, PasswordKey)
CopyMemory Plain(0), PasswordEncode(0), 16

'固定字节
Plain(35) = &H13: Plain(36) = &HF1: Plain(37) = &HCD: Plain(38) = &H6E: Plain(39) = &H3
Plain(40) = &H1F: Plain(41) = &H2D: Plain(42) = &H73: Plain(43) = &H5E: Plain(44) = &HCD
Plain(45) = &H33: Plain(46) = &HDB: Plain(47) = &H5F: Plain(48) = &HD0: Plain(49) = &HC5
Plain(50) = &HB: Plain(51) = &H1

'状态: 在线/隐身
If QQHide = True Then Plain(52) = &H28 Else Plain(52) = &HA

'固定字节
Plain(53) = &HDF: Plain(54) = &HB2: Plain(55) = &H81: Plain(56) = &HD3: Plain(57) = &HF2
Plain(58) = &HA0: Plain(59) = &H32: Plain(60) = &H46: Plain(61) = &H93: Plain(62) = &HEE
Plain(63) = &H6: Plain(64) = &HB8: Plain(65) = &H50: Plain(66) = &H2B: Plain(67) = &HC9
Plain(68) = &HFE: Plain(69) = &H18

'登陆令牌
CopyMemory Plain(70), LoginToken(0), 24

'固定字节
Plain(94) = &H1: Plain(95) = &H40

'加密数据包
Crypt = Tea.Encrypt(Plain, LoginKey)
CopyMemory Packet(27), Crypt(0), 432

'包尾
Packet(459) = &H3

LoginPacket = Packet
End Function

Public Function SendIMPacket(ByVal FromQQNum As Long, ByVal ToQQNum As Long, SessionKey() As Byte, ByVal NowTime As Long, ByVal StrSend As String) As Byte()
On Error Resume Next
Dim Packet() As Byte, Plain() As Byte, Crypt() As Byte, QQBuff(3) As Byte, ToQQBuff(3) As Byte
Dim b(19) As Byte, c() As Byte
Dim Tea As New clsTea, MD5 As New clsMD5
Dim TickCount As Long, TickCountBuff(3) As Byte
Dim I As Long, bit As Integer, bytesCount As Long
Dim SendBuff() As Byte
If UBound(SessionKey) <> 15 Then Exit Function
TickCount = NowTime
CopyMemory QQBuff(0), FromQQNum, 4
CopyMemory ToQQBuff(0), ToQQNum, 4
CopyMemory TickCountBuff(0), TickCount, 4
ReDim Packet(10) As Byte
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H16
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
bytesCount = -1
For I = 1 To Len(StrSend)
bit = Asc(Mid(StrSend, I, 1))
If bit > -1 And bit < 256 Then
bytesCount = bytesCount + 1
ReDim Preserve SendBuff(bytesCount) As Byte
SendBuff(bytesCount) = CByte(bit)
Else
bytesCount = bytesCount + 2
ReDim Preserve SendBuff(bytesCount) As Byte
SendBuff(bytesCount - 1) = HiByte(bit)
SendBuff(bytesCount) = LowByte(bit)
End If
Next I
ReDim Plain(67 + bytesCount) As Byte
Plain(0) = QQBuff(3)
Plain(1) = QQBuff(2)
Plain(2) = QQBuff(1)
Plain(3) = QQBuff(0)
Plain(4) = ToQQBuff(3)
Plain(5) = ToQQBuff(2)
Plain(6) = ToQQBuff(1)
Plain(7) = ToQQBuff(0)
Plain(8) = &HD
Plain(9) = &H51
Plain(10) = QQBuff(3)
Plain(11) = QQBuff(2)
Plain(12) = QQBuff(1)
Plain(13) = QQBuff(0)
Plain(14) = ToQQBuff(3)
Plain(15) = ToQQBuff(2)
Plain(16) = ToQQBuff(1)
Plain(17) = ToQQBuff(0)
'18 - 33 MD5
b(0) = QQBuff(3)
b(1) = QQBuff(2)
b(2) = QQBuff(1)
b(3) = QQBuff(0)
CopyMemory b(4), SessionKey(0), 16
c = MD5.DigestBAryToArray(b)
CopyMemory Plain(18), c(0), 16
Plain(34) = 0
Plain(35) = 11
Plain(36) = Int(Rnd * 256)
Plain(37) = Int(Rnd * 256)
Plain(38) = TickCountBuff(3)
Plain(39) = TickCountBuff(2)
Plain(40) = TickCountBuff(1)
Plain(41) = TickCountBuff(0)
Plain(42) = 0
Plain(43) = 0
Plain(44) = 0
Plain(45) = 0
Plain(46) = 0
Plain(47) = 1
Plain(48) = 1
Plain(49) = 0
Plain(50) = Int(Rnd * 256)
Plain(51) = Int(Rnd * 256)
Plain(52) = 2
CopyMemory Plain(53), SendBuff(0), UBound(SendBuff) + 1
Plain(UBound(Plain) - 13) = 32
Plain(UBound(Plain) - 12) = 0
Plain(UBound(Plain) - 11) = 9
Plain(UBound(Plain) - 10) = frmMain.hsRed.value
Plain(UBound(Plain) - 9) = frmMain.hsGreen.value
Plain(UBound(Plain) - 8) = frmMain.hsBlue.value
Plain(UBound(Plain) - 7) = 0
Plain(UBound(Plain) - 6) = 134
Plain(UBound(Plain) - 5) = 0
Plain(UBound(Plain) - 4) = &HCB
Plain(UBound(Plain) - 3) = &HCE
Plain(UBound(Plain) - 2) = &HCC
Plain(UBound(Plain) - 1) = &HE5
Plain(UBound(Plain)) = 13
Crypt = Tea.Encrypt(Plain, SessionKey)
ReDim Preserve Packet(12 + UBound(Crypt))
CopyMemory Packet(11), Crypt(0), UBound(Crypt) + 1
Packet(UBound(Packet)) = 3
SendIMPacket = Packet
End Function

Public Function KeepAlivePacket(ByVal QQNum As Long, SessionKey() As Byte) As Byte()
On Error Resume Next
Dim QQBuff() As Byte, Crypt() As Byte
Dim Packet() As Byte
Dim I As Long
Dim Tea As New clsTea
ReDim QQBuff(Len(Trim(Str(QQNum))) - 1) As Byte
For I = 1 To Len(Trim(Str(QQNum)))
QQBuff(I - 1) = Asc(Mid(Trim(Str(QQNum)), I, 1))
Next I
Crypt = Tea.Encrypt(QQBuff, SessionKey)
ReDim Packet(UBound(Crypt) + 12)
ReDim QQBuff(3) As Byte
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H2
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
CopyMemory Packet(11), Crypt(0), UBound(Crypt) + 1
Packet(UBound(Packet)) = 3
KeepAlivePacket = Packet
End Function

Public Function LogoutPacket(ByVal QQNum As Long, SessionKey() As Byte, PasswordKey() As Byte) As Byte()
On Error Resume Next
Dim QQBuff(3) As Byte, Packet(43) As Byte, Crypt() As Byte
Dim Tea As New clsTea
Crypt = Tea.Encrypt(PasswordKey, SessionKey)
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H1
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
CopyMemory Packet(11), Crypt(0), 32
Packet(43) = 3
LogoutPacket = Packet
End Function

小弟我写个QQ协议的，这里有个VB的挂机源代码。UDP的，但是VB看不懂，请大虾把主要的转换一下delphi的，最好用UdpSocket等写个例子。希望大虾帮帮小弟。

Attribute VB_Name = "OutPacket"
'头部:
'0 = 0x02
'1-2 = 客户端版本号码
'3-4 = 命令类型
'5-6 = 包序号 * <li>包序号, 0x05~0x06.
'7-10 = 用户 QQ 号 * <li>用户QQ号, 0x07~0x0A
'
'尾部: 0x03
Option Explicit

Public Function LoginToken(ByVal QQNum As Long) As Byte()
On Error Resume Next
Dim Packet(12) As Byte
Dim QQBuff(3) As Byte
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H62
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
Packet(11) = &H0 '请求登陆令牌
Packet(12) = &H3 '结尾
LoginToken = Packet
End Function

Public Function LoginPacket(ByVal QQNum As Long, ByVal QQHide As Boolean, LoginKey() As Byte, PasswordKey() As Byte, LoginToken() As Byte) As Byte()
On Error Resume Next
Dim Packet(459) As Byte, Plain(415) As Byte, Crypt() As Byte, QQBuff(3) As Byte, PasswordEncode() As Byte, Free() As Byte
Dim Tea As New clsTea
If UBound(LoginKey) <> 15 Then Exit Function
If UBound(PasswordKey) <> 15 Then Exit Function
If UBound(LoginToken) <> 23 Then Exit Function
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H22
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)

'初始密钥
CopyMemory Packet(11), LoginKey(0), 16

'密码密钥
PasswordEncode = Tea.Encrypt(Free, PasswordKey)
CopyMemory Plain(0), PasswordEncode(0), 16

'固定字节
Plain(35) = &H13: Plain(36) = &HF1: Plain(37) = &HCD: Plain(38) = &H6E: Plain(39) = &H3
Plain(40) = &H1F: Plain(41) = &H2D: Plain(42) = &H73: Plain(43) = &H5E: Plain(44) = &HCD
Plain(45) = &H33: Plain(46) = &HDB: Plain(47) = &H5F: Plain(48) = &HD0: Plain(49) = &HC5
Plain(50) = &HB: Plain(51) = &H1

'状态: 在线/隐身
If QQHide = True Then Plain(52) = &H28 Else Plain(52) = &HA

'固定字节
Plain(53) = &HDF: Plain(54) = &HB2: Plain(55) = &H81: Plain(56) = &HD3: Plain(57) = &HF2
Plain(58) = &HA0: Plain(59) = &H32: Plain(60) = &H46: Plain(61) = &H93: Plain(62) = &HEE
Plain(63) = &H6: Plain(64) = &HB8: Plain(65) = &H50: Plain(66) = &H2B: Plain(67) = &HC9
Plain(68) = &HFE: Plain(69) = &H18

'登陆令牌
CopyMemory Plain(70), LoginToken(0), 24

'固定字节
Plain(94) = &H1: Plain(95) = &H40

'加密数据包
Crypt = Tea.Encrypt(Plain, LoginKey)
CopyMemory Packet(27), Crypt(0), 432

'包尾
Packet(459) = &H3

LoginPacket = Packet
End Function

Public Function SendIMPacket(ByVal FromQQNum As Long, ByVal ToQQNum As Long, SessionKey() As Byte, ByVal NowTime As Long, ByVal StrSend As String) As Byte()
On Error Resume Next
Dim Packet() As Byte, Plain() As Byte, Crypt() As Byte, QQBuff(3) As Byte, ToQQBuff(3) As Byte
Dim b(19) As Byte, c() As Byte
Dim Tea As New clsTea, MD5 As New clsMD5
Dim TickCount As Long, TickCountBuff(3) As Byte
Dim I As Long, bit As Integer, bytesCount As Long
Dim SendBuff() As Byte
If UBound(SessionKey) <> 15 Then Exit Function
TickCount = NowTime
CopyMemory QQBuff(0), FromQQNum, 4
CopyMemory ToQQBuff(0), ToQQNum, 4
CopyMemory TickCountBuff(0), TickCount, 4
ReDim Packet(10) As Byte
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H16
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
bytesCount = -1
For I = 1 To Len(StrSend)
bit = Asc(Mid(StrSend, I, 1))
If bit > -1 And bit < 256 Then
bytesCount = bytesCount + 1
ReDim Preserve SendBuff(bytesCount) As Byte
SendBuff(bytesCount) = CByte(bit)
Else
bytesCount = bytesCount + 2
ReDim Preserve SendBuff(bytesCount) As Byte
SendBuff(bytesCount - 1) = HiByte(bit)
SendBuff(bytesCount) = LowByte(bit)
End If
Next I
ReDim Plain(67 + bytesCount) As Byte
Plain(0) = QQBuff(3)
Plain(1) = QQBuff(2)
Plain(2) = QQBuff(1)
Plain(3) = QQBuff(0)
Plain(4) = ToQQBuff(3)
Plain(5) = ToQQBuff(2)
Plain(6) = ToQQBuff(1)
Plain(7) = ToQQBuff(0)
Plain(8) = &HD
Plain(9) = &H51
Plain(10) = QQBuff(3)
Plain(11) = QQBuff(2)
Plain(12) = QQBuff(1)
Plain(13) = QQBuff(0)
Plain(14) = ToQQBuff(3)
Plain(15) = ToQQBuff(2)
Plain(16) = ToQQBuff(1)
Plain(17) = ToQQBuff(0)
'18 - 33 MD5
b(0) = QQBuff(3)
b(1) = QQBuff(2)
b(2) = QQBuff(1)
b(3) = QQBuff(0)
CopyMemory b(4), SessionKey(0), 16
c = MD5.DigestBAryToArray(b)
CopyMemory Plain(18), c(0), 16
Plain(34) = 0
Plain(35) = 11
Plain(36) = Int(Rnd * 256)
Plain(37) = Int(Rnd * 256)
Plain(38) = TickCountBuff(3)
Plain(39) = TickCountBuff(2)
Plain(40) = TickCountBuff(1)
Plain(41) = TickCountBuff(0)
Plain(42) = 0
Plain(43) = 0
Plain(44) = 0
Plain(45) = 0
Plain(46) = 0
Plain(47) = 1
Plain(48) = 1
Plain(49) = 0
Plain(50) = Int(Rnd * 256)
Plain(51) = Int(Rnd * 256)
Plain(52) = 2
CopyMemory Plain(53), SendBuff(0), UBound(SendBuff) + 1
Plain(UBound(Plain) - 13) = 32
Plain(UBound(Plain) - 12) = 0
Plain(UBound(Plain) - 11) = 9
Plain(UBound(Plain) - 10) = frmMain.hsRed.value
Plain(UBound(Plain) - 9) = frmMain.hsGreen.value
Plain(UBound(Plain) - 8) = frmMain.hsBlue.value
Plain(UBound(Plain) - 7) = 0
Plain(UBound(Plain) - 6) = 134
Plain(UBound(Plain) - 5) = 0
Plain(UBound(Plain) - 4) = &HCB
Plain(UBound(Plain) - 3) = &HCE
Plain(UBound(Plain) - 2) = &HCC
Plain(UBound(Plain) - 1) = &HE5
Plain(UBound(Plain)) = 13
Crypt = Tea.Encrypt(Plain, SessionKey)
ReDim Preserve Packet(12 + UBound(Crypt))
CopyMemory Packet(11), Crypt(0), UBound(Crypt) + 1
Packet(UBound(Packet)) = 3
SendIMPacket = Packet
End Function

Public Function KeepAlivePacket(ByVal QQNum As Long, SessionKey() As Byte) As Byte()
On Error Resume Next
Dim QQBuff() As Byte, Crypt() As Byte
Dim Packet() As Byte
Dim I As Long
Dim Tea As New clsTea
ReDim QQBuff(Len(Trim(Str(QQNum))) - 1) As Byte
For I = 1 To Len(Trim(Str(QQNum)))
QQBuff(I - 1) = Asc(Mid(Trim(Str(QQNum)), I, 1))
Next I
Crypt = Tea.Encrypt(QQBuff, SessionKey)
ReDim Packet(UBound(Crypt) + 12)
ReDim QQBuff(3) As Byte
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H2
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
CopyMemory Packet(11), Crypt(0), UBound(Crypt) + 1
Packet(UBound(Packet)) = 3
KeepAlivePacket = Packet
End Function

Public Function LogoutPacket(ByVal QQNum As Long, SessionKey() As Byte, PasswordKey() As Byte) As Byte()
On Error Resume Next
Dim QQBuff(3) As Byte, Packet(43) As Byte, Crypt() As Byte
Dim Tea As New clsTea
Crypt = Tea.Encrypt(PasswordKey, SessionKey)
CopyMemory QQBuff(0), QQNum, 4
Packet(0) = &H2 '头部
Packet(1) = &HD '客户端版本号码
Packet(2) = &H51
Packet(3) = &H0 '命令类型
Packet(4) = &H1
Packet(5) = Int(Rnd * 256) '包序号
Packet(6) = Int(Rnd * 256)
Packet(7) = QQBuff(3) '用户 QQ 号
Packet(8) = QQBuff(2)
Packet(9) = QQBuff(1)
Packet(10) = QQBuff(0)
CopyMemory Packet(11), Crypt(0), 32
Packet(43) = 3
LogoutPacket = Packet
End Function

它这些只是模仿出数据包，传送的代码在别出

这个应该是传送吧
Public Sub ResetServer(ByVal Index As Integer)
On Error Resume Next
Dim UdpSvr(6) As String
UdpSvr(0) = "sz.tencent.com"
UdpSvr(1) = "sz4.tencent.com"
UdpSvr(2) = "sz3.tencent.com"
UdpSvr(3) = "sz4.tencent.com"
UdpSvr(4) = "sz5.tencent.com"
UdpSvr(5) = "sz6.tencent.com"
UdpSvr(6) = "sz7.tencent.com"
QQInfo(Index).Server = UdpSvr(Int(Rnd * 7))
End Sub

Public Sub Login(ByVal Index As Integer, ByVal QQNumber As Long, ByVal QQPassword As String, ByVal QQHide As Boolean, ByVal QQAutoReply As String)
On Error Resume Next
Dim MD5 As New clsMD5
Dim PasswordKeyTemp() As Byte
If QQNumber = 0 Or QQPassword = "" Then Exit Sub
With QQInfo(Index)
.State = 0
.QQNumber = QQNumber
.QQPassword = QQPassword
.QQHide = QQHide
.QQAutoReply = QQAutoReply
PasswordKeyTemp = MD5.DigestBAryToArray(MD5.DigestStrToArray(QQPassword))
For I = 0 To 15
.PasswordKey(I) = PasswordKeyTemp(I)
.LoginKey(I) = Int(Rnd * 256)
Next I
End With
ReLogin Index
End Sub

Public Sub ReLogin(ByVal Index As Integer)
On Error Resume Next
If QQInfo(Index).QQNumber = 0 Then Exit Sub
QQInfo(Index).TimerCount = 0
QQInfo(Index).KeepAliveCount = 1
With ws(Index)
.Close
.Bind
.RemoteHost = QQInfo(Index).Server
.RemotePort = 8000
.SendData OutPacket.LoginToken(QQInfo(Index).QQNumber)
End With
End Sub

Public Sub Clear(ByVal Index As Integer)
On Error Resume Next
ws(Index).Close
With QQInfo(Index)
.State = 0
.QQNumber = 0
.QQPassword = ""
.QQHide = False
.QQAutoReply = ""
.ErrorCount = 0
.ErrorString = ""
.KeepAliveCount = 0
.AddTime = 0
.NowTime = 0
For I = 0 To 15
.LoginKey(I) = 0
.PasswordKey(I) = 0
.SessionKey(I) = 0
Next I
End With
End Sub

Public Sub Logout(ByVal Index As Integer)
On Error Resume Next
ws(Index).SendData OutPacket.LogoutPacket(QQInfo(Index).QQNumber, QQInfo(Index).SessionKey, QQInfo(Index).PasswordKey)
Clear Index
End Sub

Private Sub Form_Load()
On Error Resume Next
For I = 1 To 5000
Load ws(I)
Next I
End Sub

Private Sub tmrError_Timer()
On Error Resume Next
For I = 1 To 5000
If QQInfo(I).ErrorCount >= 5 Then Logout I
If Minute - QQInfo(I).AddTime > 2880 Then Logout I
Next I
End Sub

Private Sub tmrKeepAlive_Timer()
On Error Resume Next
For I = 1 To 5000
On Error GoTo Nexti
If QQInfo(I).QQNumber <> 0 And QQInfo(I).QQPassword <> "" And UBound(QQInfo(I).SessionKey) = 15 Then
ws(I).SendData OutPacket.KeepAlivePacket(QQInfo(I).QQNumber, QQInfo(I).SessionKey)
End If
Nexti:
Next I
End Sub

Private Sub tmrLogin_Timer()
On Error Resume Next
For I = 1 To 5000
If QQInfo(I).KeepAliveCount = 0 Then ReLogin I
QQInfo(I).KeepAliveCount = 0
QQInfo(I).TimerCount = QQInfo(I).TimerCount + 1
If QQInfo(I).TimerCount >= 20 Then
QQInfo(I).TimerCount = 0
ReLogin I
End If
Next I
End Sub

Private Sub ws_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim Buff() As Byte, SessionKeyTemp() As Byte
Dim ThisTime As Long
ReDim Buff(bytesTotal - 1) As Byte
ws(Index).GetData Buff
Select Case InPacket.GetPacketAbout(Buff)
Case 1
ws(Index).SendData OutPacket.LoginPacket(QQInfo(Index).QQNumber, QQInfo(Index).QQHide, QQInfo(Index).LoginKey, QQInfo(Index).PasswordKey, InPacket.LoginTokenReply(Buff))
Case 2
Stra = InPacket.GetLoginPacketRedirect(Buff, QQInfo(Index).LoginKey)
If Stra <> "" Then
QQInfo(Index).Server = Stra
ReLogin Index
Exit Sub
End If
Stra = InPacket.GetLoginPacketError(Buff, QQInfo(Index).LoginKey)
If Stra <> "" Then
QQInfo(Index).ErrorString = Stra
QQInfo(Index).ErrorCount = QQInfo(Index).ErrorCount + 1
If InStr(1, Stra, "密码&quot <> 0 And InStr(1, Stra, "错误&quot <> 0 Then
Logout Index
QQInfo(Index).State = 3
Else
QQInfo(Index).State = 2
End If
Exit Sub
End If
SessionKeyTemp = InPacket.GetLoginPacketSessionKey(Buff, QQInfo(Index).PasswordKey)
For I = 0 To 15
QQInfo(Index).SessionKey(I) = SessionKeyTemp(I)
Next I
ws(Index).SendData OutPacket.KeepAlivePacket(QQInfo(Index).QQNumber, QQInfo(Index).SessionKey)
QQInfo(Index).ErrorString = ""
QQInfo(Index).ErrorCount = 0
QQInfo(Index).State = 1
Case 3
If QQInfo(Index).QQAutoReply <> "" Then
ThisTime = InPacket.GetIMPacketTime(Buff, QQInfo(Index).SessionKey)
If ThisTime > QQInfo(Index).NowTime Then
QQInfo(Index).NowTime = ThisTime
ws(Index).SendData OutPacket.SendIMPacket(QQInfo(Index).QQNumber, InPacket.GetIMPacketFrom(QQInfo(Index).QQNumber, Buff, QQInfo(Index).SessionKey), QQInfo(Index).SessionKey, ThisTime, QQInfo(Index).QQAutoReply)
End If
End If
Case 4
QQInfo(Index).KeepAliveCount = QQInfo(Index).KeepAliveCount + 1
End Select
End Sub

Private Sub ws_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
On Error Resume Next
ws(Index).Close
End Sub

有一个DELPHI的QQ登录控件基于2003III版协议,做挂机足够了,QQ登录控件名:OopsQQ.来这里下载:
http://www.01cn.net/noncgi/attach/2005/04/12/9545-OopsQQ.zip

ws 是什么? Winsock 控件数组吗?

给分呀.

to 860
恩这个是可以挂
但QQ等级在QQ2004版本以下的都不再增加时间了
还有别的版本的吗？最好是UDP的
分接帖时给你，还有更好的代码吗？
我另加200分

给你一个开源网址，你去下载一个JAVA版的QQ，包含所有QQ通讯协议，从中提取协议够你用了。
http://lumaqq.linuxsir.org/main/?q=node/18

to 860
你说的那个控件在获取好友列表时，只能获取到51个，不知道是怎么回事，有没有办法解决的？

不存这个问题呀。

确实是存在的呀。你试过了吗？