qq申请器，有源码，用post提交

'
''''''''''''''''''''''''by 梦幻天空 http://menghuan.tk''''''''''''''''''''''''''''''''''''''''



Private
 Declare 
Sub
 Sleep Lib 
"
kernel32
"
 (ByVal dwMilliseconds 
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



Private
 
Const
 CP_UTF8 
=
 
65001





'
''''''''''''''''''''''''''''''以上为转UTF8所用''''''''''''''''''''''''''''''''''



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
 Type TGUID

Data1 
As
 
Long


Data2 
As
 
Integer


Data3 
As
 
Integer


Data4(
0
 
To
 
7
) 
As
 
Byte



End
 Type


'
''''''''''''''''''''''''''''以上为显示验证码图片所用，大家也可以用其他方法获取验证码图片'''''''''''''''''''''''''''''''''



Dim
 StrZ 
As
 
String



Dim
 mima 
As
 
String



Dim
 sqgs 
As
 
Integer









Private
 
Sub
 Command1_Click()



Label1.Caption 
=
 
"
正在请求http://reg.qq.com/页面
"



Dim
 strURL 
As
 
String


strURL 
=
 
"
http://reg.qq.com/
"


Inet1.Execute strURL, 
"
HEAD
"


dengdai  
'
等待数据加载完成



Label1.Caption 
=
 
"
正在请求http://reg.qq.com/页面----------------完成！
"








Label1.Caption 
=
 
"
正在获取验证码图片
"



Randomize



Set
 Picture1.Picture 
=
 
LoadPicture
(
"
http://ptlogin2.qq.com/getimage?aid=8000203
"
 
&
 
Int
(
119
 
*
 
Rnd
 
+
 
1891
))

thePCCOOKIE 
=
 Inet1.GetHeader

jishu 
=
 
InStr
(thePCCOOKIE, 
"
PCCOOKIE=
"
)

thePCCOOKIE 
=
 
Mid
(thePCCOOKIE, jishu 
+
 
9
, 
64
)


'
yanzm = InputBox("请输入验证码")



Text1.SetFocus




'
'''''''''''''''''''''''''''''''''''''''''标签1'''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Do
 Until 
Len
(Text1.Text) 
=
 
4
       
'
这里我是让程序等待Text1.Text的长度等于四，相信大家也发现了这样的弊端吧。有人问怎么不用Text1_Change事件啊！但这样就会转移过程，Inet控件封装了http协议以及ftp协议，使用起来非常方便，但也有弊端，转换了过程Inet控件里面的Cookies值也变了。申请就会失败。



DoEvents                           
'
望高手支招



Sleep 
200





'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Loop


Label1.Caption 
=
 
"
正在请求加密用的key
"


Inet1.Execute 
"
http://reg.qq.com/cgi-bin/checkconn?seed0.6238868014441234
"
, 
"
GET
"


dengdai  
'
等待数据加载完成



Label1.Caption 
=
 
"
正在请求加密用的key----------------完成！
"


jishu 
=
 
InStr
(StrZ, 
"
g_dataArray
"
)

dataArray1 
=
 
Mid
(StrZ, jishu 
+
 
33
, 
400
)

dataArrayS 
=
 
Split
(dataArray1, Chr(
34
) 
&
 Chr(
44
) 
&
 Chr(
34
), 
-
1
)

dataArray1 
=
 
Mid
(StrZ, jishu 
+
 
446
, 
64
)

dataArray 
=
 
Split
(dataArray1, 
"
,
"
, 
-
1
)




Dim
 RealPostData 
As
 
String



Dim
 l_otherRandSeed 
As
 
String


l_otherRandSeed 
=
 thePCCOOKIE

nameRand 
=
 
Array
(
6818
, 
8315
, 
5123
, 
2252
, 
0
, 
0
, 
0
, 
0
, 
0
, 
0
)






'
elementsArrName=   QQ网页注册方式、Email注册方式、昵称、申请类型（网页 or Email）、年、月、日、男、女、密码、确认密码、china、北京、东城区、验证码)        ----------注册的个人信息



mima 
=
 
"
menghuan.tk
"


elementsArrName 
=
 
Array
(
"
qq
"
, 
"
email
"
, 
"
梦幻天空
"
, 
"
0
"
, 
"
1986
"
, 
"
11
"
, 
"
25
"
, 
"
1
"
, 
"
2
"
, mima, mima, 
"
1
"
, 
"
11
"
, 
"
1
"
, Text1.Text)



len1 
=
 
Len
(l_otherRandSeed)

base 
=
 Val(
"
&H
"
 
&
 
Right
(l_otherRandSeed, 
2
))


For
 i 
=
 
0
 
To
 
12


   a 
=
 dataArray(i) 
Xor
 base

   b 
=
 
13
 
-
 i 
-
 
1


   
For
 j 
=
 
0
 
To
 
3


      a 
=
 a 
Xor
 nameRand(j)

   
Next


   a 
=
 a 
Mod
 
15


   RealPostData 
=
 RealPostData 
+
 dataArrayS(b) 
+
 
"
=
"
 
+
 elementsArrName(a) 
+
 
"
&
"
   
'
得到post用的数据



Next


Label1.Caption 
=
 
"
正在post，请稍等！
"





Dim
 myhead 
As
 
String


strURL 
=
 
"
http://reg.qq.com/cgi-bin/getnum
"


myhead 
=
 
"
Content-Type: application/x-www-form-urlencoded 
"


Inet1.Execute strURL, 
"
post
"
, RealPostData, myhead

dengdai  
'
等待数据加载完成



Label1.Caption 
=
 
"
完成！
"






qq1 
=
 
InStr
(StrZ, 
"
xyz=
"
)




If
 qq1 
<>
 
0
 
Then


   qq2 
=
 
InStr
(qq1, StrZ, 
"
;
"
)

   qqhm 
=
 
Mid
(StrZ, qq1 
+
 
5
, qq2 
-
 qq1 
-
 
6
)

   Label1.Caption 
=
 
"
恭喜你申请到一个QQ号    
"
 
+
 qqhm

   

   Text2.Text 
=
 qqhm 
+
 
"
----
"
 
+
 mima 
+
 vbCrLf 
+
 Text2.Text

   sqgs 
=
 sqgs 
+
 
1


   Label3.Caption 
=
 
"
申请记录： 
"
 
&
 sqgs

   

   

   Open App.Path 
&
 
"
\qq.txt
"
 
For
 Append 
As
 #
1


   Print #
1
, qqhm; 
"
  
"
; mima

   Close #
1



Else


  qq1 
=
 
InStr
(StrZ, 
"
此IP申请的操作过于频繁
"
)

  
If
 qq1 
<>
 
0
 
Then


      Label1.Caption 
=
 
"
此IP已被限制,请更换IP，或使用邮箱QQ。
"


  
Else


      qq1 
=
 
InStr
(StrZ, 
"
f_showInfoInLayer
"
)

      
If
 qq1 
<>
 
0
 
Then


         Label1.Caption 
=
 
"
验证码错误
"


         

       
Else


          qq1 
=
 
InStr
(StrZ, 
"
现在申请的人过多
"
)

          
If
 qq1 
<>
 
0
 
Then


          Label1.Caption 
=
 
"
现在申请的人过多，系统无法响应您的请求。
"


          
End
 
If


      
End
 
If


  
End
 
If


         


End
 
If


Text1.Text 
=
 
""



'
Call Command1_Click



End Sub







Private
 
Sub
 Command2_Click()








Dim
 strURL 
As
 
String


Label1.Caption 
=
 
"
正在请求http://emailreg.qq.com/页面
"


strURL 
=
 
"
http://emailreg.qq.com/cgi-bin/signup/step1?regtype=0
"


Inet1.Execute strURL, 
"
GET
"




dengdai

Label1.Caption 
=
 
"
正在请求http://emailreg.qq.com/页面 完成
"






asdfg 
=
 
Mid
(StrZ, 
531
, 
64
)


Randomize



Set
 Picture1.Picture 
=
 
LoadPicture
(
"
http://ptlogin2.qq.com/getimage?aid=8000203
"
 
&
 
Int
(
119
 
*
 
Rnd
 
+
 
1891
))






'
yanzm = InputBox("请输入验证码")





Text1.SetFocus

waittime (
10
)




Do
 Until 
Len
(Text1.Text) 
=
 
4


DoEvents

Sleep 
200



Loop






thesjzm 
=
 sjzm


'
Randomize



Dim
 postqq 
As
 
String


mima 
=
 
"
menghuan.tk
"
 
'
密码



postqq 
=
 
"
email=
"
 
&
 thesjzm 
&
 Chr(
38
) 
&
 
"
nick=梦幻天空
"
 
&
 Chr(
38
) 
&
 
"
age=1989
"
 
&
 Chr(
38
) 
&
 
"
age_month=9
"
 
&
 Chr(
38
) 
&
 
"
age_day=20
"
 
&
 Chr(
38
) 
&
 
"
regsex=1
"
 
&
 Chr(
38
) 
&
 
"
password_1=
"
 
&
 mima 
&
 Chr(
38
) 
&
 
"
password_2=
"
 
&
 mima 
&
 Chr(
38
) 
&
 
"
Country=1
"
 
&
 Chr(
38
) 
&
 
"
State=1
"
 
&
 Chr(
38
) 
&
 
"
City=1
"
 
&
 Chr(
38
) 
&
 
"
validecode=
"
 
&
 Text1.Text 
&
 Chr(
38
) 
&
 
"
regqqmail=1
"
 
&
 Chr(
38
) 
&
 
"
asdfg=
"
 
&
 asdfg 
&
 Chr(
38
)         
'
 regqqmail=1是qq.com  。 regqqmail=3是foxmail.com





Label1.Caption 
=
 
"
正在post
"



Dim
 myhead 
As
 
String




strURL 
=
 
"
http://emailreg.qq.com/cgi-bin/signup/reg_result
"




myhead 
=
 
"
Content-Type: application/x-www-form-urlencoded 
"


Inet1.Execute strURL, 
"
post
"
, postqq, myhead



dengdai

Label1.Caption 
=
 
"
post完成
"






qq1 
=
 
InStr
(StrZ, 
"
申请成功
"
)


If
 qq1 
<>
 
0
 
Then


  qq2 
=
 
InStr
(qq1 
+
 
90
, StrZ, Chr(
34
))

  qqhm 
=
 
Mid
(StrZ, qq1 
+
 
86
, qq2 
-
 qq1 
-
 
86
)

  thesjzm 
=
 thesjzm 
&
 
"
@qq.com
"


  

  Text2.Text 
=
 qqhm 
+
 
"
---
"
 
+
 thesjzm 
+
 
"
---
"
 
+
 mima 
+
 vbCrLf 
+
 Text2.Text

  sqgs 
=
 sqgs 
+
 
1


  Label3.Caption 
=
 
"
申请记录： 
"
 
&
 sqgs

  

  

  

  

  Open App.Path 
&
 
"
\qqemail.txt
"
 
For
 Append 
As
 #
1


  Print #
1
, qqhm; 
"
  
"
; mima; 
"
  
"
; thesjzm 
'
 regqqmail=1是qq.com  。 regqqmail=3是foxmail.com



  Close #
1


  Label1.Caption 
=
 
"
恭喜你申请到一个QQ号    
"
 
+
 qqhm 
+
 
"
     
"
 
+
 thesjzm


Else




    qq1 
=
 
InStr
(StrZ, 
"
非法访问
"
)

    
If
 qq1 
<>
 
0
 
Then


      Label1.Caption 
=
 
"
非法访问
"


    

    
Else


          qq1 
=
 
InStr
(StrZ, 
"
验证码错误
"
)

          
If
 qq1 
<>
 
0
 
Then


             Label1.Caption 
=
 
"
验证码错误
"


          
Else


             qq1 
=
 
InStr
(StrZ, 
"
操作过于频繁
"
)

             
If
 qq1 
<>
 
0
 
Then


                Label1.Caption 
=
 
"
操作过于频繁
"


             
Else


                qq1 
=
 
InStr
(StrZ, 
"
该帐号已被注册
"
)

                
If
 qq1 
<>
 
0
 
Then


                Label1.Caption 
=
 
"
该帐号已被注册
"


                
End
 
If


             
End
 
If


             

           
End
 
If


     
End
 
If


           


End
 
If


Text1.Text 
=
 
""





'
Call Command2_Click



End Sub





Private
 
Sub
 Form_Load()

Label1.Caption 
=
 
"
请选择申请通道
"


Label2.Caption 
=
 
"
请输入验证码
"


Label3.Caption 
=
 
"
申请记录：
"


Command1.Caption 
=
 
"
无保QQ
"


Command2.Caption 
=
 
"
邮箱QQ
"





End Sub





Private
 
Sub
 Form_Unload(Cancel 
As
 
Integer
)


End



End Sub





Private
 
Sub
 Inet1_StateChanged(ByVal State 
As
 
Integer
)


If
 State 
=
 icResponseCompleted 
Then



Dim
 BinBuff() 
As
 
Byte




BinBuff 
=
 Inet1.GetChunk(
0
, icByteArray)

StrZ 
=
 Utf8ToUnicode(BinBuff)


End
 
If



End Sub



Sub
 dengdai()


Do
 Until Inet1.StillExecuting 
=
 
False
 
'
等待数据加载完成



DoEvents


Loop



End Sub


 
Private
 
Function
 sjzm() 
As
 
String
  
'
随机字母



 
Dim
 i%, trec%, a%()

 trec 
=
 
12


 
ReDim
 a%(trec)

 

 

  
Randomize


  
For
 i 
=
 
1
 
To
 trec

 a(i) 
=
 
Int
(
Rnd
 
*
 (
122
 
-
 
97
 
+
 
1
)) 
+
 
97
 
'
小写字母



 
'
a(i) = Int(Rnd * (90 - 65 + 1)) + 65 '大写字母



 
Next
 i

Me.Cls

 
For
 i 
=
 
1
 
To
 trec

 

 sjzm 
=
 Chr(a(i)) 
&
 sjzm

 

 
Next
 i

 
End Function


   

 




Public
 
Function
 
LoadPicture
(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, 
LoadPicture



Exit
 
Function


LocalErr:


Set
 
LoadPicture
 
=
 VB.LoadPicture(strFileName)

Err.Clear


End Function







Private
 
Sub
 waittime(delay 
As
 
Single
) 
'
''''''''''''''''''''''''等待模板



Dim
 starttime 
As
 
Single


starttime 
=
 
Timer



Do
 Until (
Timer
 
-
 starttime) 
>
 delay

shijian 
=
 
Timer
 
-
 starttime

Label1.Caption 
=
 
"
延时十秒 
"
 
&
 shijian

DoEvents


Loop


Label1.Caption 
=
 
"
延时十秒 10
"



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


 


Private
 
Sub
 Picture1_Click()


Randomize



Set
 Picture1.Picture 
=
 
LoadPicture
(
"
http://ptlogin2.qq.com/getimage?aid=8000203
"
 
&
 
Int
(
119
 
*
 
Rnd
 
+
 
1891
))





Text1.SetFocus


End Sub




转自：http://topic.csdn.net/u/20100724/23/1d229a85-7709-4b44-9886-27d24504fe79.html?53850#r_achor