vb登录qq源码完整无错版

投稿人:网络 | 发布时间:2015-08-12 18:52 | 分类:热门QQ技巧 | 点击量:

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

Private Const CP_UTF8 = 65001

Dim yzm$, y%, z  As Boolean

Private Function getHtmlStr$(strUrl$)                                           '获取源码

    Dim XmlHttp

    Set XmlHttp = CreateObject("Microsoft.XMLHTTP")

    XmlHttp.Open "GET", strUrl, True

    XmlHttp.send

    stime = Now                                                                 '获取当前时间

    While XmlHttp.ReadyState <> 4

        DoEvents

        ntime = Now                                                             '获取循环时间

        If DateDiff("s", stime, ntime) > 3 Then getHtmlStr = "": Exit Function  '判断超出3秒即超时退出过程

    Wend

    getHtmlStr = StrConv(XmlHttp.ResponseBody, vbUnicode)

    Set XmlHttp = Nothing

End Function

                                                                   

Private Sub Command1_Click()

    Dim ScriptControl As Object, PostDate$, code$

    code = getHtmlStr("?uin=" & Text1.Text & "")

    If code = "" Then MsgBox "获取信息失败", vbInformation, "超时": Exit Sub

    If InStr(code, "!") = 0 Then

        If Len(Text3.Text) = 0 Then MsgBox "请输入验证码": Exit Sub

        yzm = Text3.Text

    Else

        yzm = Mid(code, InStr(code, "!"), 4)

        Text3.Text = yzm

    End If

    Set ScriptControl = ScriptControl1

    ScriptControl1.Language = "Jscript"

    ScriptControl1.Timeout = -1

    ScriptControl1.AddCode txtVarHexcase.Text

    Psw = ScriptControl1.Run("md5", ScriptControl1.Run("md5_3", "" & Text2.Text & "") + UCase(yzm))

    y = 0: z = False

    PostDate = "u=" & Text1.Text & "&p=" & Psw & "&verifycode=" & yzm & "&webqq_type=1&remember_uin=1&aid=1002101&u1=http%3A%2F%2Fweb.qq.com%2Fmain.shtml%3Fdirect_15_21&h=1&ptredirect=1&ptlang=2052&from_ui=1&pttype=1&dumy=&fp=loginerroralert"

    Inet1.Execute "?", "POST", PostDate, "Referer: [url]?style=4&appid=1002101&enable_qlogin=0&no_verifyimg=1&s_url=http://web.qq.com/main.shtml?direct_11_14&f_url=loginerroralert[/url]" & vbCrLf & "Content-Type: application/x-www-form-urlencoded"

End Sub

                                                                        

Private Sub GetVcode()

    y = 0: z = True

    Inet1.Execute "", "GET"

End Sub

                                                                        

Private Sub Form_Load()

    Call GetVcode

End Sub

                                                                        

Private Sub Picture1_Click()

    y = 0: z = True

    Inet1.Execute "", "GET"

End Sub

                                                                        

Private Sub Inet1_StateChanged(ByVal State As Integer)

    Dim BinBuff() As Byte

    If State = 12 Then

        If y = 1 Then

            Dim strData$: strData = ""

            Dim bDone As Boolean: bDone = False

            vtData = Inet1.GetChunk(1024, icString)

            Do While Not bDone

                strData = strData & vtData

                DoEvents

                vtData = Inet1.GetChunk(1024, icString)

                If Len(vtData) = 0 Then

                    bDone = True

                End If

            Loop

        ElseIf y = 0 Then

            Dim Buff() As Byte

            Buff = Inet1.GetChunk(0, icByteArray)

            If z = False Then

                If InStr(Utf8ToUnicode(Buff), "QQ社区登录") <> 0 Then

                    Me.Caption = "登陆成功"

                    a1 = InStr(Inet1.GetHeader(Cookie), "uin"): b1 = InStr(Inet1.GetHeader(Cookie), "skey"): c1 = InStr(Inet1.GetHeader(Cookie), "ptwebqq")

                    If a1 = 0 Or b1 = 0 Or c1 = 0 Then Me.Caption = "cookie出错": Exit Sub

                    a2 = InStr(a1, Inet1.GetHeader(Cookie), ";"): a3 = Mid(Inet1.GetHeader(Cookie), a1 + 5, a2 - a1 - 5)

                    b2 = InStr(b1, Inet1.GetHeader(Cookie), ";"): b3 = Mid(Inet1.GetHeader(Cookie), b1 + 5, b2 - b1 - 5)

                    c2 = InStr(c1, Inet1.GetHeader(Cookie), ";"): c3 = Mid(Inet1.GetHeader(Cookie), c1 + 8, c2 - c1 - 8)

                    z = False: y = 1

                    Inet1.Execute "", "POST", "" & a3 & ";22;0;00000000;" & b3 & ";" & c3 & ";0;"

                Else

                    MsgBox Utf8ToUnicode(Buff)

                    Call GetVcode

                End If

            Else

                Open App.Path & "\temp.jpg" For Binary As #1

                    Put #1, , Buff

                Close #1

                Picture1.Picture = LoadPicture(App.Path & "\temp.jpg")

            End If

        End If

    End If

End Sub

                                                                        

Function Utf8ToUnicode(ByRef Utf() As Byte) As String

    Dim lRet As Long

    Dim lLength As Long

    Dim lBufferSize As Long

    lLength = UBound(Utf) - LBound(Utf) + 1

    If lLength <= 0 Then Exit Function

    lBufferSize = lLength * 2

    Utf8ToUnicode = String$(lBufferSize, Chr(0))

    lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)

    If lRet <> 0 Then

        Utf8ToUnicode = Left(Utf8ToUnicode, lRet)

    Else

        Utf8ToUnicode = ""

    End If

End Function


数据统计中,请稍等!
您可能会对以下内容感兴趣