VB6实现QQ登陆网页

Option Explicit
Private State(4)       As Long
Private ByteCounter    As Long
Private ByteBuffer(63) As Byte
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function OleLoadPicturePath _
Lib "oleaut32.dll" (ByVal szURLorPath As Long, _
ByVal punkCaller As Long, _
ByVal dwReserved As Long, _
ByVal clrReserved As OLE_COLOR, _
ByRef riid As TGUID, _
ByRef ppvRet As IPicture) As Long
Private Declare Function MultiByteToWideChar _
Lib "KERNEL32" (ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long) As Long
Function QQcode(ByVal P As String, ByVal C As String) As String
Dim i     As Long, j As Long, k As Long, t As String
Dim d(15) As Byte
MD5Init
MD5Update Len(P), StrToArray(P)
MD5Final
For k = 0 To 1
For j = 1 To 4
t = Right("00000000" & Hex(State(j)), 8)
For i = 0 To 3
d(4 * (j - 1) + i) = CByte("&H" & Mid(t, 8 - i * 2 - 1, 2))
Next i
Next j
MD5Init
MD5Update 16, d
MD5Final
Next k
t = GetValues
t = t & UCase(C)
QQcode = MD5(t)
End Function

Public Function MD5(lStr As String) As String
MD5Init
MD5Update Len(lStr), StrToArray(lStr)
MD5Final
MD5 = GetValues
End Function

Private Function StrToArray(InString As String) As Byte()
Dim i           As Integer
Dim bytBuffer() As Byte
ReDim bytBuffer(Len(InString))
For i = 0 To Len(InString) - 1
bytBuffer(i) = Asc(Mid(InString, i + 1, 1))
Next i
StrToArray = bytBuffer
End Function

Private Function GetValues() As String
GetValues = L2S(State(1)) & L2S(State(2)) & L2S(State(3)) & L2S(State(4))
End Function

Private Function L2S(Num As Long) As String
Dim a As Byte
Dim b As Byte
Dim C As Byte
Dim d As Byte
a = Num And &HFF&
If a < 16 Then
L2S = "0" & Hex(a)
Else
L2S = Hex(a)
End If
b = (Num And &HFF00&) / 256
If b < 16 Then
L2S = L2S & "0" & Hex(b)
Else
L2S = L2S & Hex(b)
End If
C = (Num And &HFF0000) / 65536
If C < 16 Then
L2S = L2S & "0" & Hex(C)
Else
L2S = L2S & Hex(C)
End If
If Num < 0 Then
d = ((Num And &H7F000000) / 16777216) Or &H80&
Else
d = (Num And &HFF000000) / 16777216
End If
If d < 16 Then
L2S = L2S & "0" & Hex(d)
Else
L2S = L2S & Hex(d)
End If
End Function

Private Sub MD5Init()
ByteCounter = 0
State(1) = UtL(1732584193#)
State(2) = UtL(4023233417#)
State(3) = UtL(2562383102#)
State(4) = UtL(271733878#)
End Sub

Private Sub MD5Final()
Dim dblBits          As Double
Dim padding(72)      As Byte
Dim lngBytesBuffered As Long
padding(0) = &H80
dblBits = ByteCounter * 8
lngBytesBuffered = ByteCounter Mod 64
If lngBytesBuffered <= 56 Then
MD5Update 56 - lngBytesBuffered, padding
Else
MD5Update 120 - ByteCounter, padding
End If
padding(0) = UtL(dblBits) And &HFF&
padding(1) = UtL(dblBits) / 256 And &HFF&
padding(2) = UtL(dblBits) / 65536 And &HFF&
padding(3) = UtL(dblBits) / 16777216 And &HFF&
padding(4) = 0
padding(5) = 0
padding(6) = 0
padding(7) = 0
MD5Update 8, padding
End Sub

Private Sub MD5Update(InputLen As Long, InBuffer() As Byte)
Dim II                 As Integer
Dim i                  As Integer
Dim j                  As Integer
Dim k                  As Integer
Dim lngBufferedBytes   As Long
Dim lngBufferRemaining As Long
Dim lngRem             As Long
lngBufferedBytes = ByteCounter Mod 64
lngBufferRemaining = 64 - lngBufferedBytes
ByteCounter = ByteCounter + InputLen
If InputLen >= lngBufferRemaining Then
For II = 0 To lngBufferRemaining - 1
ByteBuffer(lngBufferedBytes + II) = InBuffer(II)
Next II
MD5Transform ByteBuffer
lngRem = (InputLen) Mod 64
For i = lngBufferRemaining To InputLen - II - lngRem Step 64
For j = 0 To 63
ByteBuffer(j) = InBuffer(i + j)
Next j
MD5Transform ByteBuffer
Next i
lngBufferedBytes = 0
Else
i = 0
End If
For k = 0 To InputLen - i - 1
ByteBuffer(lngBufferedBytes + k) = InBuffer(i + k)
Next k
End Sub

Private Sub MD5Transform(Buffer() As Byte)
Dim X(16) As Long
Dim a     As Long
Dim b     As Long
Dim C     As Long
Dim d     As Long
a = State(1)
b = State(2)
C = State(3)
d = State(4)
Decode 64, X, Buffer
FF a, b, C, d, X(0), 7, -680876936
FF d, a, b, C, X(1), 12, -389564586
FF C, d, a, b, X(2), 17, 606105819
FF b, C, d, a, X(3), 22, -1044525330
FF a, b, C, d, X(4), 7, -176418897
FF d, a, b, C, X(5), 12, 1200080426
FF C, d, a, b, X(6), 17, -1473231341
FF b, C, d, a, X(7), 22, -45705983
FF a, b, C, d, X(8), 7, 1770035416
FF d, a, b, C, X(9), 12, -1958414417
FF C, d, a, b, X(10), 17, -42063
FF b, C, d, a, X(11), 22, -1990404162
FF a, b, C, d, X(12), 7, 1804603682
FF d, a, b, C, X(13), 12, -40341101
FF C, d, a, b, X(14), 17, -1502002290
FF b, C, d, a, X(15), 22, 1236535329
GG a, b, C, d, X(1), 5, -165796510
GG d, a, b, C, X(6), 9, -1069501632
GG C, d, a, b, X(11), 14, 643717713
GG b, C, d, a, X(0), 20, -373897302
GG a, b, C, d, X(5), 5, -701558691
GG d, a, b, C, X(10), 9, 38016083
GG C, d, a, b, X(15), 14, -660478335
GG b, C, d, a, X(4), 20, -405537848
GG a, b, C, d, X(9), 5, 568446438
GG d, a, b, C, X(14), 9, -1019803690
GG C, d, a, b, X(3), 14, -187363961
GG b, C, d, a, X(8), 20, 1163531501
GG a, b, C, d, X(13), 5, -1444681467
GG d, a, b, C, X(2), 9, -51403784
GG C, d, a, b, X(7), 14, 1735328473
GG b, C, d, a, X(12), 20, -1926607734
HH a, b, C, d, X(5), 4, -378558
HH d, a, b, C, X(8), 11, -2022574463
HH C, d, a, b, X(11), 16, 1839030562
HH b, C, d, a, X(14), 23, -35309556
HH a, b, C, d, X(1), 4, -1530992060
HH d, a, b, C, X(4), 11, 1272893353
HH C, d, a, b, X(7), 16, -155497632
HH b, C, d, a, X(10), 23, -1094730640
HH a, b, C, d, X(13), 4, 681279174
HH d, a, b, C, X(0), 11, -358537222
HH C, d, a, b, X(3), 16, -722521979
HH b, C, d, a, X(6), 23, 76029189
HH a, b, C, d, X(9), 4, -640364487
HH d, a, b, C, X(12), 11, -421815835
HH C, d, a, b, X(15), 16, 530742520
HH b, C, d, a, X(2), 23, -995338651
II a, b, C, d, X(0), 6, -198630844
II d, a, b, C, X(7), 10, 1126891415
II C, d, a, b, X(14), 15, -1416354905
II b, C, d, a, X(5), 21, -57434055
II a, b, C, d, X(12), 6, 1700485571
II d, a, b, C, X(3), 10, -1894986606
II C, d, a, b, X(10), 15, -1051523
II b, C, d, a, X(1), 21, -2054922799
II a, b, C, d, X(8), 6, 1873313359
II d, a, b, C, X(15), 10, -30611744
II C, d, a, b, X(6), 15, -1560198380
II b, C, d, a, X(13), 21, 1309151649
II a, b, C, d, X(4), 6, -145523070
II d, a, b, C, X(11), 10, -1120210379
II C, d, a, b, X(2), 15, 718787259
II b, C, d, a, X(9), 21, -343485551
State(1) = Add(State(1), a)
State(2) = Add(State(2), b)
State(3) = Add(State(3), C)
State(4) = Add(State(4), d)
End Sub

Private Sub Decode(Length As Integer, OutBuffer() As Long, InBuffer() As Byte)
Dim intDblIndex  As Integer
Dim intByteIndex As Integer
Dim dblSum       As Double
intDblIndex = 0
For intByteIndex = 0 To Length - 1 Step 4
dblSum = InBuffer(intByteIndex) + InBuffer(intByteIndex + 1) * 256# + InBuffer(intByteIndex + 2) * 65536# + InBuffer(intByteIndex + 3) * 16777216#
OutBuffer(intDblIndex) = UtL(dblSum)
intDblIndex = intDblIndex + 1
Next intByteIndex
End Sub

Private Function FF(a As Long, _
b As Long, _
C As Long, _
d As Long, _
X As Long, _
s As Long, _
ac As Long) As Long
a = Add4(a, (b And C) Or (Not (b) And d), X, ac)
a = LLR(a, s)
a = Add(a, b)
End Function

Private Function GG(a As Long, _
b As Long, _
C As Long, _
d As Long, _
X As Long, _
s As Long, _
ac As Long) As Long
a = Add4(a, (b And d) Or (C And Not (d)), X, ac)
a = LLR(a, s)
a = Add(a, b)
End Function

Private Function HH(a As Long, _
b As Long, _
C As Long, _
d As Long, _
X As Long, _
s As Long, _
ac As Long) As Long
a = Add4(a, b Xor C Xor d, X, ac)
a = LLR(a, s)
a = Add(a, b)
End Function

Private Function II(a As Long, _
b As Long, _
C As Long, _
d As Long, _
X As Long, _
s As Long, _
ac As Long) As Long
a = Add4(a, C Xor (b Or Not (d)), X, ac)
a = LLR(a, s)
a = Add(a, b)
End Function

Function LLR(value As Long, bits As Long) As Long
Dim lngSign As Long
Dim lngI    As Long
bits = bits Mod 32
If bits = 0 Then LLR = value: Exit Function
For lngI = 1 To bits
lngSign = value And &HC0000000
value = (value And &H3FFFFFFF) * 2
value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000)
Next
LLR = value
End Function

Private Function Add(Val1 As Long, Val2 As Long) As Long
Dim lngHighWord As Long
Dim lngLowWord  As Long
Dim lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
lngOverflow = lngLowWord / 65536
lngHighWord = (((Val1 And &HFFFF0000) / 65536) + ((Val2 And &HFFFF0000) / 65536) + lngOverflow) And &HFFFF&
Add = UtL((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function

Private Function Add4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
Dim lngHighWord As Long
Dim lngLowWord  As Long
Dim lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
lngOverflow = lngLowWord / 65536
lngHighWord = (((Val1 And &HFFFF0000) / 65536) + ((Val2 And &HFFFF0000) / 65536) + ((val3 And &HFFFF0000) / 65536) + ((val4 And &HFFFF0000) / 65536) + lngOverflow) And &HFFFF&
Add4 = UtL((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function

Private Function UtL(value As Double) As Long
If value < 0 Or value >= 4294967296# Then Error 6
If value <= 2147483647 Then
UtL = value
Else
UtL = value - 4294967296#
End If
End Function
Private Function LoadPic(ByVal strFileName As String) As Picture
Dim IID As TGUID
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
On Error GoTo LocalErr
OleLoadPicturePath StrPtr(strFileName), 0&, 0&, 0&, IID, LoadPic
Exit Function
LocalErr:
Set LoadPic = VB.LoadPicture(strFileName)
Err.Clear
End Function
Private Function UTF8_Decode(bUTF8() As Byte) As String
Dim lRet        As Long
Dim lLen        As Long
Dim lBufferSize As Long
Dim sBuffer     As String
Dim bBuffer()   As Byte
lLen = UBound(bUTF8) + 1
If lLen = 0 Then Exit Function
lBufferSize = lLen * 2
sBuffer = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(65001, 0, VarPtr(bUTF8(0)), lLen, StrPtr(sBuffer), lBufferSize)
If lRet <> 0 Then
sBuffer = Mid(sBuffer, 1, lRet)
End If
UTF8_Decode = sBuffer
End Function
Private Function getInfo(ByVal URL As String) As String
Dim BinBuff() As Byte
Inet1.Execute URL, "GET"
Do While Inet1.StillExecuting
DoEvents
Loop
BinBuff = Inet1.GetChunk(0, icByteArray)
'BinBuff = Inet1.GetChunk(0, icString)

getInfo = UTF8_Decode(BinBuff)
'getInfo = BinBuff
End Function
Private Function RegExpTest(patrn As String, strng As String) As String
Dim Re  As Object
Dim Rec As Object
Set Re = CreateObject("VBScript.RegExp")
Re.Global = True
Re.Pattern = patrn
Set Rec = Re.Execute(strng)
RegExpTest = Rec(4).value

Set Rec = Nothing
Set Re = Nothing
End Function
Private Sub Form_Load()
Dim Vcode     As String
Dim QQNum     As String
Dim Pwd       As String
Dim BinBuff() As Byte
Dim getData   As String
Dim Result    As String
Const Referer = "http://qzone.qq.com/"
Randomize
QQNum = InputBox("输入QQ号码")
Pwd = InputBox("输入密码")
Set Pic1.Picture = LoadPic("http://captcha.qq.com/getimage?aid=46000101&uin=" & QQNum & "&" & Timer & "&vc_type=")
Me.Show
Vcode = InputBox("输入验证码")
getData = "http://ptlogin2.qq.com/login?u=" & QQNum & "&p=" & QQcode(Pwd, Vcode) & "&verifycode=" & Vcode & "&=on&aid=46000101&u1=http%3A%2F%2Fimgcache.qq.com%2Fqzone%2Fv5%2Floginsucc.html%3Fpara%3Dizone&ptredirect=1&h=1&from_ui=1&dumy=&fp=loginerroralert"
Inet1.Execute getData, "GET", , vbCrLf & "Referer:" & Referer
Do While Inet1.StillExecuting
DoEvents
Loop
BinBuff = Inet1.GetChunk(0, icByteArray)

Result = UTF8_Decode(BinBuff)
MsgBox RegExpTest("'.*?'", Result) '显示结果
End Sub