QQ农场外挂源码-VB源代码

Option Explicit
'|-------------------------------------------------
'|
'| 程序：QQ农场辅助 [2012/02/04]
'| 制作：E旺 QQ 407542585
'|
'|-------------------------------------------------
Dim http As XMLHttpClass
Dim header_Referer As String
Dim g_myFarmUrl As String, g_FriendUrl As String, g_timerCount As Long
Dim meHeight As Long, meWidth As Long
Dim meList1Height As Long, meList1Width As Long
'| 参数：qqUser    - [in]QQ号码
'|       qqPsw     - [in]QQ密码
'|       DengJi    - [out]等级
'|       JingYan   - [out]经验
'|       JinBi     - [out]金币
'|       FriendUrl - [out/Optional]好友页面的URL
'|
'| 返回：Boolean(True-登录成功, False-登录失败)
'|
Private Function 登录QQ农场(ByVal qqUser As String, ByVal qqPsw As String, ByRef DengJi As String, ByRef JingYan As String, ByRef JinBi As String, Optional ByRef FriendUrl As String = "1") As Boolean
Dim gUrl As String, Data, retB As Boolean
Dim pUrl As String, pData As String ', pRef As String
Dim verUrl As String, verPath As String, verCode As String
Dim i As Long, Arr, one As String, sName As String, sValue As String
'显示状态
showStatus "开始登录账号：" & qqUser, 2
'重新建立连接
Set http = Nothing
Set http = New XMLHttpClass
retB = False
'打开登录页
gUrl = "http://pt.3g.qq.com/s?aid=nLogin"
Data = http.GetData(gUrl, gUrl, "", "utf-8")
header_Referer = gUrl
Data = SubstringExtraction(Data, "<form", "</form>", 1, 1)
'取得登录地址和组合要提交的数据
pUrl = SubstringExtraction(Data, "action=""", """", 1, 0)
'pData = "login_url=http%3A%2F%2Fpt.3g.qq.com%2Fs%3Faid%3DnLogin&q_from=&loginTitle=%E6%89%8B%E6%9C%BA%E8%85%BE%E8%AE%AF%E7%BD%91&bid=0&go_url=http%3A%2F%2Finfo.3g.qq.com&qq=" & qqUser & "&pwd=" & qqPsw & "&loginType=3&loginsubmit=%E7%99%BB%E5%BD%95"
pData = "login_url=http%3A%2F%2Fpt.3g.qq.com%2Fs%3Faid%3DnLogin&q_from=&loginTitle=%E6%89%8B%E6%9C%BA%E8%85%BE%E8%AE%AF%E7%BD%91&bid=0&go_url=http%3A%2F%2Fnc.z.qq.com%2Ffarm%2Findex.jsp&qq=" & qqUser & "&pwd=" & qqPsw & "&loginType=3&loginsubmit=%E7%99%BB%E5%BD%95"
'开始登录
Data = http.PostData(pUrl, pData, header_Referer, "", "utf-8")
header_Referer = pUrl
If InStr(Data, ">退出</a>") Then
'登录成功
retB = True
Else
'登录失败
If InStr(Data, "输入验证码") Then
'显示状态
showStatus "要求输入验证码！"
'要输验证码
verUrl = SubstringExtraction(Data, "<img src=""", """", 1, 0)
verPath = App.Path & "\vCode.gif"
Call http.DownFile(verUrl, header_Referer, "", verPath)
'显示验证码
verCodeForm.Show
verCodeForm.Picture1.Picture = LoadPicture(verPath)
verCode = InputBox("请输入窗体中显示的验证码", "输入验证码", "")
verCodeForm.隐藏窗体
If verCode <> "" Then
'取得当前表单数据
Data = SubstringExtraction(Data, "<form action=""/handleLogin", "</form>", 1, 1)
pUrl = Left(header_Referer, InStr(8, header_Referer, "/") - 1)
pUrl = pUrl & SubstringExtraction(Data, "action=""", """", 1, 0) 'POST的地址
If CutSubstringToArray(Arr, Data, "<input", "/>", 1, 1) Then
pData = ""
For i = 0 To UBound(Arr)
one = Arr(i)
If one <> "" Then
sName = SubstringExtraction(one, "name=""", """", 1, 0)
sValue = SubstringExtraction(one, "value=""", """", 1, 0)
one = sName & "=" & sValue
If pData = "" Then
pData = one
Else
pData = pData & "&" & one
End If
End If
Next
'再次用验证码登录
pData = Replace(pData, "verify=NotFound", "verify=" & verCode) 'POST的数据
Data = http.PostData(pUrl, pData, header_Referer, "", "utf-8")
header_Referer = pUrl
If InStr(Data, ">退出</a>") Then
'登录成功
retB = True
End If
End If
End If
Else
retB = False
End If
End If
'取得登录结果
If retB Then
showStatus "登录成功！"
'取账号详情
DengJi = SubstringExtraction(Data, "等级:", " ", 1, 0)
JingYan = SubstringExtraction(Data, "经验:", "<", 1, 0)
JinBi = SubstringExtraction(Data, "金币:", "<", 1, 0)
'取“好友农场”链接
If FriendUrl <> "1" Then
FriendUrl = SubstringExtraction(Data, "我的农场", "好友农场", 1, 0)
FriendUrl = SubstringExtraction(FriendUrl, "href=""", """", 1, 0)
End If
'取“我的农场”链接
g_myFarmUrl = SubstringExtraction(Data, ">回我的应用</a>)<", ">我的农场</a", 1, 0)
g_myFarmUrl = SubstringExtraction(g_myFarmUrl, "href=""", """", 1, 0)
Else
showStatus "登录失败！"
End If
登录QQ农场 = retB
End Function
'| 参数：FriendUrl - 好友页面的地址
'|
'| 返回：String(URL列表，一行一条)
'|
Private Function 取可操作的好友链接列表(ByVal FriendUrl As String, Optional nPage As Long = 1)
Dim gUrl As String, Data
Dim sp, i As Long, one As String, fUrl As String, returnData
'显示状态
showStatus "正在取好友页第" & nPage & "页。。。"
returnData = ""
'加些随机延时
Wait RandomizeNumber(200, 1000)
'取一页
gUrl = FriendUrl
Data = http.GetData(gUrl, header_Referer, "", "utf-8")
header_Referer = gUrl
'摘取
sp = Split(Data, "（摘取）")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
'除草
sp = Split(Data, "（除草）")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
'取下页
If InStr(Data, "下页") Then
sp = Split(Data, "下页")
one = sp(0)
gUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
gUrl = Left(gUrl, InStr(gUrl, """") - 1)
gUrl = Replace(gUrl, "&", "&")
Data = ""
'递归取完所有页
returnData = returnData & 取可操作的好友链接列表(gUrl, nPage + 1)
End If
showStatus "取好友页第" & nPage & "页完毕！"
取可操作的好友链接列表 = returnData
End Function
'| 参数：FriendUrlList - 好友页面地址列表
'|
'| 返回：String(URL列表，一行一条)
'|
Private Function 取可操作的摘取链接地址(ByVal FriendUrlList As String)
Dim gUrl As String, Data, returnData
Dim spList, sp, one As String, X As Long, i As Long, fUrl As String
'显示状态
showStatus "取可摘取链接。。。"
returnData = ""
spList = Split(FriendUrlList, vbCrLf)
'遍历URL列表
For X = 0 To UBound(spList)
showStatus "第" & (X + 1) & "页。。。"
one = spList(X)
If InStr(LCase(one), "http") Then
'加些随机延时
Wait RandomizeNumber(200, 600)
'打开一个好友页
gUrl = one
Data = http.GetData(gUrl, header_Referer, "", "utf-8")
'摘取
sp = Split(Data, ">摘取</a> ")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
'除草
sp = Split(Data, ">除草</a> ")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
'杀虫
sp = Split(Data, ">杀虫</a> ")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
'浇水
sp = Split(Data, ">浇水</a> ")
If UBound(sp) > 0 Then
For i = 0 To UBound(sp) - 1
one = sp(i)
fUrl = Mid(one, InStrRev(one, "<a href=""") + 9)
fUrl = Left(fUrl, InStr(fUrl, """") - 1)
fUrl = Replace(fUrl, "&", "&")
returnData = returnData & fUrl & vbCrLf
Next
End If
End If
Next
'显示状态
If returnData = "" Then
showStatus "取摘取链接完毕，没有可摘取作物！"
Else
showStatus "取摘取链接完毕，得到" & UBound(Split(returnData, vbCrLf)) & "个可摘取作物！"
End If
取可操作的摘取链接地址 = returnData
End Function
'| 参数：UrlList - 摘取地址列表
'|
'| 返回：
'|
Private Function 摘取除草杀虫浇水(ByVal UrlList As String)
Dim gUrl As String, Data
Dim spList, one As String, X As Long
spList = Split(UrlList, vbCrLf)
For X = 0 To UBound(spList)
one = spList(X)
If InStr(LCase(one), "http") Then
'加些随机延时
Wait RandomizeNumber(200, 600)
'摘取一个
gUrl = one
Data = http.GetData(gUrl, header_Referer, "", "utf-8")
Data = SubstringExtraction(Data, "<p class=""txt-warning2"">", "</p", 1, 0)
'判断摘取结果
If InStr(Data, "成功") Then
Data = Replace(Data, vbCrLf, "")
Data = Replace(Data, Chr(9), "")
Data = Replace(Data, "<br/>", "")
Data = Trim(Data)
showStatus Data
End If
End If
Next
End Function
'| 取个人信息
Private Function 取账号明细() As Boolean
Dim Data, retB As Boolean
Dim DengJi As String, JingYan As String, JinBi As String
Data = http.GetData(g_myFarmUrl, "", "", "utf-8")
retB = False
If InStr(Data, "退出") Then
DengJi = SubstringExtraction(Data, "等级:", " ", 1, 0)
JingYan = SubstringExtraction(Data, "经验:", "<", 1, 0)
JinBi = SubstringExtraction(Data, "金币:", "<", 1, 0)
Me.Text1.Text = "等级：" & DengJi & vbCrLf & "经验：" & JingYan & vbCrLf & "金币：" & JinBi & vbCrLf & vbCrLf & Time
retB = True
Else
Me.Text1.Text = "请先登录"
End If
取账号明细 = retB
End Function
Private Sub Check1_Click()
If Check1 Then
g_timerCount = 1
Me.Timer1.Interval = 1000
Me.Timer1.Enabled = True
showStatus "开始自动偷菜", 8
Else
Me.Timer1.Enabled = False
showStatus "停止自动偷菜", 8
End If
End Sub
Private Sub Command1_Click()
Dim qqUser As String, qqPsw As String, Data
Dim DengJi As String, JingYan As String, JinBi As String
Dim friendArray, linkList As String
Command1.Enabled = False
qqUser = Me.Text2.Text
qqPsw = Me.Text3.Text
If 登录QQ农场(qqUser, qqPsw, DengJi, JingYan, JinBi, g_FriendUrl) Then
Me.Text1.Text = "等级：" & DengJi & vbCrLf & "经验：" & JingYan & vbCrLf & "金币：" & JinBi
Me.Check1.Enabled = True
If MsgBox("登录成功，是否自动偷菜？", 4, "EnVon") = vbYes Then
Me.Check1.Value = 1
End If
Else
Me.Check1.Enabled = False
MsgBox "登录失败"
End If
If 2 = 3 Then
If g_FriendUrl <> "" Then
'查看好友农场
Data = 取可操作的好友链接列表(g_FriendUrl)
'取好友果实
Data = 取可操作的摘取链接地址(Data)
Call 摘取除草杀虫浇水(Data)
End If
End If
Command1.Enabled = True
End Sub
Private Sub Command2_Click()
Call 取账号明细
End Sub
Private Sub Form_Load()
meHeight = Me.Height
meWidth = Me.Width
meList1Height = Me.List1.Height
meList1Width = Me.List1.Width
Me.Timer1.Enabled = False
g_timerCount = 1
Set http = New XMLHttpClass
Me.List1.Clear
Me.Check1.Enabled = False
End Sub
Private Sub Form_Resize()
On Error Resume Next
Dim h As Long, w As Long
h = Me.Height - meHeight
w = Me.Width - meWidth
Me.List1.Height = meList1Height + h
Me.List1.Width = meList1Width + w
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set http = Nothing
End
End Sub
Private Function CQ(ss)
Dim i, s
For i = 1 To Len(ss)
s = s & Chr(Asc(Mid(ss, i, 1)) + 11)
Next
CQ = s
End Function
Private Sub showStatus(s, Optional ByVal m As Long)
If m = 2 Then Me.List1.Clear
List1.AddItem Time & Chr(9) & s
End Sub
Private Sub Timer1_Timer()
Dim Data
If g_timerCount = 1 Then
If 取账号明细 Then
showStatus "开始偷菜。。。", 8
'查看好友农场
Data = 取可操作的好友链接列表(g_FriendUrl)
'取好友果实
Data = 取可操作的摘取链接地址(Data)
Call 摘取除草杀虫浇水(Data)
Else
showStatus "登录超时或者与服务器断开，无法偷菜，请先登录！", 8
Check1.Value = 0
Timer1.Enabled = False
End If
Else
If g_timerCount Mod 5 = 0 Then showStatus "休息中。。。"
End If
g_timerCount = g_timerCount + 1
If g_timerCount >= RandomizeNumber(30, 60) Then
showStatus "检测好友农场。。。", 2
g_timerCount = 1
End If
End Sub

示例下载地址：http://download.csdn.net/detail/envon123/4050466

QQ农场外挂源码-VB源代码相关推荐

C、C++、VC、MFC网页自动注册、登陆、发帖、留言 QQ注册、QQ申请器源码、源代码
查看文章 [转]C.C++.VC.MFC网页自动注册.登陆.发帖.留言 QQ注册.QQ申请器源码.源代码 2012-01-11 10:58 转载自 qq316293804 最终编辑 qq31629 ...
mfc使用cef源代码实现_如何获得微信小游戏跳一跳源码以及源代码组合包括哪些...
很多小游戏都是由源代码编写而成的,那大家知道源代码组合包括哪些吗?手机游戏源代码怎么使用的呢?还有,如何获得微信小游戏跳一跳源码?下面就由奇瑰网小编带大家来了解一下相关的内容吧. 源代码组合包括哪些 ...
如何拷贝工程_如何获得微信小游戏跳一跳源码以及源代码组合包括哪些
很多小游戏都是由源代码编写而成的,那大家知道源代码组合包括哪些吗?手机游戏源代码怎么使用的呢?还有,如何获得微信小游戏跳一跳源码?下面就由奇瑰网小编带大家来了解一下相关的内容吧. 源代码组合包括哪些 ...
如何用php农场项目,2020全新亲测php农场游戏源码-金币菇种植理财区块链源码带商城系统...
2020全新亲测php农场游戏源码-金币菇种植理财区块链源码带商城系统+抽奖系统+独家搭建教程金币菇一款复利理财游戏,在这里大家可以更轻松.愉快的进行理财投资!本源码是一套理财游戏盘系统,蘑菇只是 ...
php淘金农场源码,2018Thinkphp仿淘金农场开源源码统H5农场复利源码带商城仓库商店...
演示地址:如有演示站请以演示为准,无演示站以截图为准,源码太多服务器有限,无法搭建所有源码演示站,请谅解! 新手购买指导:1.在本站注册账号丨 2.登录已注册账号充值源码所需金币丨 3.登录账号下 ...
c语言小游戏跳一跳代码及注释,如何获得微信小游戏跳一跳源码以及源代码组合包括哪些...
原标题:如何获得微信小游戏跳一跳源码以及源代码组合包括哪些很多小游戏都是由源代码编写而成的,那大家知道源代码组合包括哪些吗?手机游戏源代码怎么使用的呢?还有,如何获得微信小游戏跳一跳源码?下面就由奇 ...
模仿qq客户端应用源码且带安装包
这款源码案例是模仿qq客户端应用源码且带安装包,大家可以参考一下吧,也是比较完整的一款Android源码项目. 源码下载: http://code.662p.com/view/1931.html 00 ...
C++、VC++、MFC网页自动注册、登陆、发帖、留言，QQ注册、QQ申请器源码、注册邮箱源码、自动发帖源码...
C++.VC++.MFC网页自动注册.登陆.发帖.留言,QQ注册.QQ申请器源码.注册邮箱源码.自动发帖源码参考资料: 自动登录yahoo邮箱http://blog.csdn.net/suisu ...
如何用c#制作QQ农场外挂
前一篇文章我大致写了一下如何制作QQ农场外挂,最近我的外挂运行了一段时间,觉得还行,所以拿出来给大家下载试用试用大致功能有: 1.我的资料,查看我的等级,经验,金钱等信息 2.我的农场:可以查看我的 ...

QQ农场外挂源码-VB源代码

QQ农场外挂源码-VB源代码相关推荐

最新文章

热门文章