本来想采用xmlhttp的、不过这个呢好像设置来源有点问题、所以就换了我比较不熟悉的inet组件（很久不用VB、其实VB也不太熟悉啦、哈哈）、废话不多说、直接贴代码：(有点乱、见谅吧)
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
