QQ批量自动申请源码

Eddy 发布于2010-8-1 19:10:7 分类: 程序设计 已浏览loading 网友评论0条 我要评论

转自VBGood,By vbload。

源码:

QQ申请 Option Explicit Private Sub Command1_Click() On Error GoTo Err Dim Province As String '省 Dim City As String '市 Dim strHead As String If VerifyCode.Text = "" Or Len(VerifyCode.Text) <> 4 Or NickName.Text = "" Or (UsrPsw.Text = "" Or Len(UsrPsw.Text) < 6) Then MsgBox "请检查注册信息是否正确输入!" Exit Sub End If NameRand = Array(6818, 8315, 5123, 2252) If Option1 Then Sex = "1" Else Sex = "2" '性别选择 Province = Right(Combo5.Text, Len(Combo5.Text) - InStr(Combo5.Text, ":")) City = Right(Combo6.Item(Combo5.ListIndex), Len(Combo6.Item(Combo5.ListIndex)) - InStr(Combo6.Item(Combo5.ListIndex), ":")) ElementsArrName = Array("", "", NickName.Text, "0", Combo1.Text, CStr(Val(Combo2.Text)), CStr(Val(Combo3.Text)), Sex, "2", Trim(UsrPsw.Text), Trim(UsrPsw.Text), "1", Province, City, VerifyCode.Text) '----------------------"qq","email"'可以为空 For i = 0 To 12 a = Val(DataArrayShort(i)) Xor BaseNum b = 12 - i For j = 0 To 3 a = a Xor NameRand(j) Next a = a Mod 15 PostData = PostData + DataArrayLong(b) + "=" + ElementsArrName(a) + "&" Next strHead = "Content-Type: application/x-www-form-urlencoded" Label11.Caption = "开始申请……" ReturnCode = "" ReturnCode = GetInfoByInet("", "http://reg.qq.com/cgi-bin/getnum", "POST", PostData, strHead, 2, ProxyIP) '代理IP--ProxyIP If InStr(ReturnCode, "xyz=") <> 0 Then NewQQNum = RemoveHeadTail(ReturnCode, "var xyz=""", """;") Label11.Caption = "恭喜你申请到一个QQ号:" + NewQQNum VerifyCode.Text = "" Open App.Path & "\qq.txt" For Append As #1 Print #1, NewQQNum; "----"; Trim(UsrPsw.Text); " 申请日期:"; Format(Now, "yyyy年mm月dd日") Close #1 Call RefreshVerifyCode ElseIf InStr(ReturnCode, "f_showInfoInLayer") <> 0 Then Label11.Caption = "验证码错误" ElseIf InStr(ReturnCode, "对不起,此IP申请的操作过于频繁") <> 0 Then Label11.Caption = "此IP已被限制,请更换IP,或使用邮箱QQ。" ElseIf InStr(ReturnCode, "现在申请的人过多") <> 0 Then Label11.Caption = "现在申请的人过多,系统无法响应您的请求。" End If Exit Sub Err: Label11.Caption = "抱歉,申请过程中发生错误,未能成功!" End Sub Private Sub Combo5_Click() '点击显示相应省、市辖区 On Error Resume Next Dim i As Integer If Combo5.ListIndex = 31 Or Combo5.ListIndex = 32 Then For i = 0 To 33 Combo6.Item(i).Visible = False Next i Else Combo6.Item(Combo5.ListIndex).Visible = True End If Combo6.Item(Combo5.ListIndex).ZOrder 0 '置于顶层 Combo6.Item(Combo5.ListIndex).ListIndex = 0 End Sub Private Sub Form_Activate() Call RefreshVerifyCode End Sub Private Sub Form_Load() On Error Resume Next Dim a As Control Dim i As Integer For Each a In Me.Controls If LCase(TypeName(a)) = "textbox" Then a.Text = "" Next For i = 1 To 50 Combo1.AddItem 2010 - i '年 If i < 13 Then Combo2.AddItem Format(i, "00") '月 If i < 32 Then Combo3.AddItem Format(i, "00") '日 Next i Combo4.AddItem "中国" For i = 1 To 33 Load Combo6(i) Next i If GetGeoInfo Then For i = 1 To 5 Controls("Combo" & i).ListIndex = 0 Next i Else Combo5.AddItem "江苏 :32" Combo6(0).AddItem "镇江 :11" Combo4.ListIndex = 0 Combo5.ListIndex = 0 Combo6(0).ListIndex = 0 End If Combo1.ListIndex = 24 UsrPsw.PasswordChar = "*" Option1.Value = True End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub Image1_Click() '刷新验证码 Call RefreshVerifyCode End Sub Private Sub Label10_Click() '刷新验证码 Call RefreshVerifyCode End Sub Option Explicit Private Sub Command1_Click() On Error GoTo Err Dim Province As String '省 Dim City As String '市 Dim strHead As String If VerifyCode.Text = "" Or Len(VerifyCode.Text) <> 4 Or NickName.Text = "" Or (UsrPsw.Text = "" Or Len(UsrPsw.Text) < 6) Then MsgBox "请检查注册信息是否正确输入!" Exit Sub End If NameRand = Array(6818, 8315, 5123, 2252) If Option1 Then Sex = "1" Else Sex = "2" '性别选择 Province = Right(Combo5.Text, Len(Combo5.Text) - InStr(Combo5.Text, ":")) City = Right(Combo6.Item(Combo5.ListIndex), Len(Combo6.Item(Combo5.ListIndex)) - InStr(Combo6.Item(Combo5.ListIndex), ":")) ElementsArrName = Array("", "", NickName.Text, "0", Combo1.Text, CStr(Val(Combo2.Text)), CStr(Val(Combo3.Text)), Sex, "2", Trim(UsrPsw.Text), Trim(UsrPsw.Text), "1", Province, City, VerifyCode.Text) '----------------------"qq","email"'可以为空 For i = 0 To 12 a = Val(DataArrayShort(i)) Xor BaseNum b = 12 - i For j = 0 To 3 a = a Xor NameRand(j) Next a = a Mod 15 PostData = PostData + DataArrayLong(b) + "=" + ElementsArrName(a) + "&" Next strHead = "Content-Type: application/x-www-form-urlencoded" Label11.Caption = "开始申请……" ReturnCode = "" ReturnCode = GetInfoByInet("", "http://reg.qq.com/cgi-bin/getnum", "POST", PostData, strHead, 2, ProxyIP) '代理IP--ProxyIP If InStr(ReturnCode, "xyz=") <> 0 Then NewQQNum = RemoveHeadTail(ReturnCode, "var xyz=""", """;") Label11.Caption = "恭喜你申请到一个QQ号:" + NewQQNum VerifyCode.Text = "" Open App.Path & "\qq.txt" For Append As #1 Print #1, NewQQNum; "----"; Trim(UsrPsw.Text); " 申请日期:"; Format(Now, "yyyy年mm月dd日") Close #1 Call RefreshVerifyCode ElseIf InStr(ReturnCode, "f_showInfoInLayer") <> 0 Then Label11.Caption = "验证码错误" ElseIf InStr(ReturnCode, "对不起,此IP申请的操作过于频繁") <> 0 Then Label11.Caption = "此IP已被限制,请更换IP,或使用邮箱QQ。" ElseIf InStr(ReturnCode, "现在申请的人过多") <> 0 Then Label11.Caption = "现在申请的人过多,系统无法响应您的请求。" End If Exit Sub Err: Label11.Caption = "抱歉,申请过程中发生错误,未能成功!" End Sub Private Sub Combo5_Click() '点击显示相应省、市辖区 On Error Resume Next Dim i As Integer If Combo5.ListIndex = 31 Or Combo5.ListIndex = 32 Then For i = 0 To 33 Combo6.Item(i).Visible = False Next i Else Combo6.Item(Combo5.ListIndex).Visible = True End If Combo6.Item(Combo5.ListIndex).ZOrder 0 '置于顶层 Combo6.Item(Combo5.ListIndex).ListIndex = 0 End Sub Private Sub Form_Activate() Call RefreshVerifyCode End Sub Private Sub Form_Load() On Error Resume Next Dim a As Control Dim i As Integer For Each a In Me.Controls If LCase(TypeName(a)) = "textbox" Then a.Text = "" Next For i = 1 To 50 Combo1.AddItem 2010 - i '年 If i < 13 Then Combo2.AddItem Format(i, "00") '月 If i < 32 Then Combo3.AddItem Format(i, "00") '日 Next i Combo4.AddItem "中国" For i = 1 To 33 Load Combo6(i) Next i If GetGeoInfo Then For i = 1 To 5 Controls("Combo" & i).ListIndex = 0 Next i Else Combo5.AddItem "江苏 :32" Combo6(0).AddItem "镇江 :11" Combo4.ListIndex = 0 Combo5.ListIndex = 0 Combo6(0).ListIndex = 0 End If Combo1.ListIndex = 24 UsrPsw.PasswordChar = "*" Option1.Value = True End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub Image1_Click() '刷新验证码 Call RefreshVerifyCode End Sub Private Sub Label10_Click() '刷新验证码 Call RefreshVerifyCode End Sub

GetWebInfoByInet模块

QQ申请Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public BaseNum%, i%, j%, b%, a& Public ReturnCode$, Cookie$, Sex$, DataArrayLong$(), DataArrayShort$(), ProxyIP$ '代理IP Public AREACODE$, PCCOOKIE$, PCCOOKIE2$, verifysession$, PostData$, NewQQNum$ Public ElementsArrName(), NameRand() Public Function SaveFileFromRes(vntResourceID As Variant, sType As String, sFileName As String) As Boolean '释放资源文件 On Error GoTo SaveFileFromRes_Err Dim bytImage() As Byte Dim iFileNum As Integer SaveFileFromRes = True bytImage = LoadResData(vntResourceID, sType) iFileNum = FreeFile Open sFileName For Binary As iFileNum Put #iFileNum, , bytImage Close iFileNum Exit Function SaveFileFromRes_Err: SaveFileFromRes = False: Exit Function End Function Sub Main() '启动时检查是否有所需文件 On Error Resume Next If Dir("C:\Documents and Settings\Administrator\属地代码.txt", vbDirectory) = "" Then SaveFileFromRes 101, "CUSTOM", "C:\Documents and Settings\Administrator\属地代码.txt" End If Sleep (1) Form1.Show End Sub Function RefreshVerifyCode() '刷新验证码 On Error Resume Next Dim tem As String Dim i As Integer ReturnCode = "": AREACODE = "": PCCOOKIE = "" PCCOOKIE2 = "": Cookie = "": tem = "": verifysession = "" ReturnCode = GetInfoByInet(Form1, "http://reg.qq.com/", "GET", "", "", 1, ProxyIP) '请求Cookie AREACODE = "AREACODE=" & RemoveHeadTail(ReturnCode, "AREACODE=", ";") & "; " PCCOOKIE = "PCCOOKIE=" & RemoveHeadTail(ReturnCode, "PCCOOKIE=", ";") BaseNum = Val("&H" & Right(PCCOOKIE, 2)) PCCOOKIE = PCCOOKIE & "; " PCCOOKIE2 = "PCCOOKIE2=" & RemoveHeadTail(ReturnCode, "PCCOOKIE2=", ";") Cookie = AREACODE + PCCOOKIE + PCCOOKIE2 ReturnCode = GetInfoByInet(Form1, "http://ui.ptlogin2.qq.com/cgi-bin/getimage?aid=1000801&0." & GetRanNum(17), "GET", "", "", 2, ProxyIP) '获得验证码及Cookie verifysession = "verifysession=" & RemoveHeadTail(ReturnCode, "verifysession=", ";") Cookie = Cookie & "; " & verifysession ReturnCode = GetInfoByInet("", "http://reg.qq.com/cgi-bin/checkconn?seed0." & GetRanNum(16), "GET", "", "", 2, ProxyIP) '得到构造参数的KEY值 DataArrayLong = Split(RemoveHeadTail(ReturnCode, "g_dataArray=new Array(new Array(""", """)"), """,""") DataArrayShort = Split(RemoveHeadTail(ReturnCode, "),new Array(", "),"), ",") End Function Function GetInfoByInet(ByVal frm As Variant, URL As String, ByVal UsrType As String, ByVal PostData As String, _ ByVal strHead As String, ByVal CookieOrSource As Integer, ByVal Proxy As String) As String '得到资源的主函数 Dim Inet As Object Set Inet = CreateObject("InetCtls.Inet") If Proxy <> "" Then Inet.AccessType = 2 Inet.Proxy = Proxy End If If PostData <> "" Then Inet.Execute URL, UsrType, PostData, strHead Else Inet.Execute URL, UsrType End If Do Until Inet.StillExecuting = False DoEvents Loop If LCase(TypeName(frm)) = "form1" Then Dim StrPath As String StrPath = App.Path & "\VerifyCode.jpg" If CookieOrSource = 1 Then GetInfoByInet = Inet.GetHeader Else Dim BinBuff() As Byte BinBuff = Inet.GetChunk(0, icByteArray) If Dir(StrPath) <> "" Then Kill StrPath Open StrPath For Binary As #1 Put #1, , BinBuff Close #1 Set frm.Image1.Picture = LoadPicture(StrPath) Kill StrPath End If Else GetInfoByInet = Inet.GetChunk(0, icString) End If End Function Function GetRanNum(ByVal LenNum As Integer) As String Dim i As Integer Dim tem As String tem = "" For i = 1 To LenNum Randomize tem = tem & CStr(Int(Rnd * 9)) Next i GetRanNum = tem End Function Function RemoveHeadTail(ByVal Source As Variant, ByVal sStart As String, ByVal strEnd As String) As String '去除指定字符串的首尾字符 On Error Resume Next Dim m As Long Dim n As Long RemoveHeadTail = "" m = InStr(1, Source, sStart) If m <> 0 Then n = InStr(m + Len(sStart) + 1, Source, strEnd) If n <> 0 Then RemoveHeadTail = Mid(Source, m + Len(sStart), n - m - Len(sStart)) Else Exit Function End If Else Exit Function End If End Function Function GetGeoInfo() As Boolean '读取属地信息数据 On Error Resume Next Dim i, j As Integer Dim s As String If Dir("C:\Documents and Settings\Administrator\属地代码.txt") <> "" Then Open "C:\Documents and Settings\Administrator\属地代码.txt" For Input As #1 i = -1 Do Until EOF(1) Line Input #1, s If Left(s, 2) = "--" Then i = i + 1 j = -1 Form1.Combo5.AddItem Right(Trim(s), Len(Trim(s)) - 2) Else Form1.Combo6.Item(i).AddItem s End If Loop Close #1 GetGeoInfo = True Else MsgBox "未发现属地支持文件!" GetGeoInfo = False End If End Function Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public BaseNum%, i%, j%, b%, a& Public ReturnCode$, Cookie$, Sex$, DataArrayLong$(), DataArrayShort$(), ProxyIP$ '代理IP Public AREACODE$, PCCOOKIE$, PCCOOKIE2$, verifysession$, PostData$, NewQQNum$ Public ElementsArrName(), NameRand() Public Function SaveFileFromRes(vntResourceID As Variant, sType As String, sFileName As String) As Boolean '释放资源文件 On Error GoTo SaveFileFromRes_Err Dim bytImage() As Byte Dim iFileNum As Integer SaveFileFromRes = True bytImage = LoadResData(vntResourceID, sType) iFileNum = FreeFile Open sFileName For Binary As iFileNum Put #iFileNum, , bytImage Close iFileNum Exit Function SaveFileFromRes_Err: SaveFileFromRes = False: Exit Function End Function Sub Main() '启动时检查是否有所需文件 On Error Resume Next If Dir("C:\Documents and Settings\Administrator\属地代码.txt", vbDirectory) = "" Then SaveFileFromRes 101, "CUSTOM", "C:\Documents and Settings\Administrator\属地代码.txt" End If Sleep (1) Form1.Show End Sub Function RefreshVerifyCode() '刷新验证码 On Error Resume Next Dim tem As String Dim i As Integer ReturnCode = "": AREACODE = "": PCCOOKIE = "" PCCOOKIE2 = "": Cookie = "": tem = "": verifysession = "" ReturnCode = GetInfoByInet(Form1, "http://reg.qq.com/", "GET", "", "", 1, ProxyIP) '请求Cookie AREACODE = "AREACODE=" & RemoveHeadTail(ReturnCode, "AREACODE=", ";") & "; " PCCOOKIE = "PCCOOKIE=" & RemoveHeadTail(ReturnCode, "PCCOOKIE=", ";") BaseNum = Val("&H" & Right(PCCOOKIE, 2)) PCCOOKIE = PCCOOKIE & "; " PCCOOKIE2 = "PCCOOKIE2=" & RemoveHeadTail(ReturnCode, "PCCOOKIE2=", ";") Cookie = AREACODE + PCCOOKIE + PCCOOKIE2 ReturnCode = GetInfoByInet(Form1, "http://ui.ptlogin2.qq.com/cgi-bin/getimage?aid=1000801&0." & GetRanNum(17), "GET", "", "", 2, ProxyIP) '获得验证码及Cookie verifysession = "verifysession=" & RemoveHeadTail(ReturnCode, "verifysession=", ";") Cookie = Cookie & "; " & verifysession ReturnCode = GetInfoByInet("", "http://reg.qq.com/cgi-bin/checkconn?seed0." & GetRanNum(16), "GET", "", "", 2, ProxyIP) '得到构造参数的KEY值 DataArrayLong = Split(RemoveHeadTail(ReturnCode, "g_dataArray=new Array(new Array(""", """)"), """,""") DataArrayShort = Split(RemoveHeadTail(ReturnCode, "),new Array(", "),"), ",") End Function Function GetInfoByInet(ByVal frm As Variant, URL As String, ByVal UsrType As String, ByVal PostData As String, _ ByVal strHead As String, ByVal CookieOrSource As Integer, ByVal Proxy As String) As String '得到资源的主函数 Dim Inet As Object Set Inet = CreateObject("InetCtls.Inet") If Proxy <> "" Then Inet.AccessType = 2 Inet.Proxy = Proxy End If If PostData <> "" Then Inet.Execute URL, UsrType, PostData, strHead Else Inet.Execute URL, UsrType End If Do Until Inet.StillExecuting = False DoEvents Loop If LCase(TypeName(frm)) = "form1" Then Dim StrPath As String StrPath = App.Path & "\VerifyCode.jpg" If CookieOrSource = 1 Then GetInfoByInet = Inet.GetHeader Else Dim BinBuff() As Byte BinBuff = Inet.GetChunk(0, icByteArray) If Dir(StrPath) <> "" Then Kill StrPath Open StrPath For Binary As #1 Put #1, , BinBuff Close #1 Set frm.Image1.Picture = LoadPicture(StrPath) Kill StrPath End If Else GetInfoByInet = Inet.GetChunk(0, icString) End If End Function Function GetRanNum(ByVal LenNum As Integer) As String Dim i As Integer Dim tem As String tem = "" For i = 1 To LenNum Randomize tem = tem & CStr(Int(Rnd * 9)) Next i GetRanNum = tem End Function Function RemoveHeadTail(ByVal Source As Variant, ByVal sStart As String, ByVal strEnd As String) As String '去除指定字符串的首尾字符 On Error Resume Next Dim m As Long Dim n As Long RemoveHeadTail = "" m = InStr(1, Source, sStart) If m <> 0 Then n = InStr(m + Len(sStart) + 1, Source, strEnd) If n <> 0 Then RemoveHeadTail = Mid(Source, m + Len(sStart), n - m - Len(sStart)) Else Exit Function End If Else Exit Function End If End Function Function GetGeoInfo() As Boolean '读取属地信息数据 On Error Resume Next Dim i, j As Integer Dim s As String If Dir("C:\Documents and Settings\Administrator\属地代码.txt") <> "" Then Open "C:\Documents and Settings\Administrator\属地代码.txt" For Input As #1 i = -1 Do Until EOF(1) Line Input #1, s If Left(s, 2) = "--" Then i = i + 1 j = -1 Form1.Combo5.AddItem Right(Trim(s), Len(Trim(s)) - 2) Else Form1.Combo6.Item(i).AddItem s End If Loop Close #1 GetGeoInfo = True Else MsgBox "未发现属地支持文件!" GetGeoInfo = False End If End Function

已经有(0)位网友发表了评论,你也评一评吧!
原创文章如转载,请注明:转载自Eddy Blog
原文地址:http://www.rrgod.com/program/476.html     欢迎订阅Eddy Blog

记住我的信息,下次不用再输入 欢迎给Eddy Blog留言