' ''''''''''''''''''''''''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