VB6实现QQ登陆网页

本来想采用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

VB6实现QQ登陆网页相关推荐

电脑网络正常，网页都可以上，但是QQ登陆不上，报错代码00001
电脑网络正常,网页什么的都可以打开,就是QQ登陆不了,报错代码00001 可以尝试关闭防火墙试试. 如果不行的话试试将网络属性的"Internet 协议版本6(TCP/IPv6)" ...
java+登录window域认证网页_Java 实现 QQ 登陆
1. 前言 2. 后台设计 2.1. 数据库设计 2.2. 鉴权流程 3. QQ登陆 3.1. 实名认证 3.2. 创建应用 3.3. 引导用户登录 3.4. 拿到accessToken 3.5. 获 ...
python爬虫登陆网页版腾讯课堂
根据腾讯课堂网页登陆问题进行解说(需要安装谷歌浏览器): 1.导入库 ----------------------------------------------------------------- ...
qq登陆inc.php,登陆验证 qq登陆验证 php 登陆验证
用户登录验证脚本,Chkpwd.asp '=======用户登录验证脚本======= '如果尚未定义Passed对象,则将其定义为false,表示没有通过验证 If IsEmpty(Session( ...
模仿QQ空间网页设计
模仿QQ空间网页设计目的:1.通过模仿QQ空间,全自主写代码,熟悉网页设计的流程 2.熟练的掌握HTML.CSS.JS的应用 3.将在此过程中遇到的问题及其解决方法记录在此,以便取用. 开始: 一 ...
html手机qq登陆验证码,为什么qq登陆需要验证码？qq登陆需要验证码怎么取消？...
为什么qq登陆需要验证码?qq登陆需要验证码怎么取消?很多用户在登陆qq时,总是需要输入验证码,一些用户表示很烦,那么大家知道为什么qq登陆需要验证码吗?如果不想每次登陆qq都需要验证码该如何取消呢? ...
使用HTML表单和表格完成静态QQ登陆界面
使用HTML表单和表格完成静态QQ登陆界面一.创建过程创建表单创建表格创建行创建单元格创建表单组建二.原理使用表单来显示收集用户信息并用表格来帮助排版三.主要代码 1. <ta ...
java山寨qq_java图形界面之山寨QQ登陆界面
要山寨出QQ登陆界面,首先要对java的图形界面有一定的了解.在jdk1.4之前,图形界面所用到的所有类和接口都在javax.awt之下,在其之后就都在javax.swing里了. 关于图形界面的开发 ...
itchat库账号安全无法登陆网页微信
itchat库账号安全无法登陆网页微信无聊学习itchat库时,碰到的问题.却告知,再三感谢!!! import itchat, json# hotReload表示热部署,这样调试的时候就不用频繁 ...

VB6实现QQ登陆网页

VB6实现QQ登陆网页相关推荐

最新文章

热门文章