外挂编程

开发平台：

Visual Basic

Form1.frm：源码内容

yzmlx.rzl = czzl(Index)
yzmlx.bj = SH_bj(Index)
yzmlx.name = SH_name(Index)
yzmlx.id = SH_id(Index)
If csyzm = True Then
csyzm = False
Call xyyzm '弹出验证码
Else
csyzm = True
yzmcode = "&validatemsg=" & Int(Rnd * 9000 + 1000)
Call SendHttp(yzmlx.lx, yzmlx.uID, yzmlx.id, yzmlx.name, yzmlx.bj, yzmlx.rzl)
End If
Debug.Print "请输入验证码" & " 类型：" & lx
Exit Sub
End If
csyzm = False
If lx = 1 Then '收获果实
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 0 Then
If SH_bj(Index) = "0" Then Call jilu("收获", MyQQ, farmlandIndex + 1 & "号农田收获失败，因为这块地没东西可收获!")
Else
cId = split_m(1, SH_Temp(Index), "cId") '收获种类
exp = split_m(1, SH_Temp(Index), "exp") '获得经验
harvest = split_m(1, SH_Temp(Index), "harvest") '获得数量
Call jilu("收获", MyQQ, farmlandIndex + 1 & "号农田收获成功，得到了" & harvest & "个【" & Replace(zhonglei(cId, 0), "　", "") & "】,经验:+" & exp)
Call addsxlb(Myuid, rzl) '加入刷新列表
Call tongji(1, cId, harvest, exp) '统计收益
End If
ElseIf lx = 2 Then '偷取果实
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
Fkey = split_m(3, SH_Temp(Index), "fkey") '获取key
If Len(Fkey) = 96 Then '记录偷取key
If InStr(keyutemp, "/" & SH_uid(Index) & "/") = 0 Then
keyutemp = keyutemp & "/" & SH_uid(Index) & "/"
keyu(keyjl).uID = SH_uid(Index)
keyu(keyjl).key = Fkey
keyu(keyjl).time = Time_C
keyjl = keyjl + 1
Else
For i = 0 To keyjl - 1
If SH_uid(Index) = keyu(i).uID Then
keyu(i).key = Fkey
keyu(keyjl).time = Time_C
Exit For
End If
Next i
End If
End If
If code = 1 Then
cId = split_m(1, SH_Temp(Index), "cId") '收获种类
harvest = split_m(1, SH_Temp(Index), "harvest") '获得数量
If InStr(SH_Temp(Index), "u72d7u72d7u53d1u73b0") > 0 Or InStr(SH_Temp(Index), "狗狗发现") > 0 Then
money = split_m(2, SH_Temp(Index), "money") '获得数量
Call jilu("偷取", MyQQ, "偷取好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田果实,被狗狗发现,逃跑中掉落" & Abs(money) & "个金币。")
Call tongji(4, 0, Abs(money), 0) '统计收益
Else
Call jilu("偷取", MyQQ, "偷取好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田果实成功,得到了" & harvest & "个[" & Replace(zhonglei(cId, 0), "　", "") & "]")
Call tongji(2, cId, harvest, 0) '统计收益
End If
Call xiemdb(1, SH_uid(Index), farmlandIndex + 1) '写入数据库
Else
If InStr(SH_Temp(Index), "direction") > 0 Then
direction = vbUnEscape(split_m(3, SH_Temp(Index), "direction"))
Else
direction = vbUnEscape(split_m(3, SH_Temp(Index), "error"))
End If
If Len(direction) > 0 Then
If SH_bj(Index) = "0" Then Call jilu("偷取", MyQQ, "偷取好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田果实失败,提示:" & direction)
Else
If SH_bj(Index) = "0" Then Call jilu("偷取", MyQQ, "偷取好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田果实失败!")
End If
If InStr(SH_Temp(Index), "做人不能贪得无厌") > 0 Or InStr(SH_Temp(Index), "狗盯上了你，别做坏事了") > 0 Or InStr(SH_Temp(Index), "u72D7u76EFu4E0Au4E86u4F60uFF0Cu522Bu505Au574Fu4E8Bu4E86") > 0 Then
Call xiemdb(1, SH_uid(Index), farmlandIndex + 1) '写入数据库
End If
End If
ElseIf lx = 3 Then '除虫
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 1 Then
money = split_m(1, SH_Temp(Index), "money") '金钱
exp = split_m(1, SH_Temp(Index), "exp") '经验
sum = split_m(2, SH_Temp(Index), "pest") '剩余数量
If exp > 0 Or xzbz = 0 Or SH_bj(Index) = "0" Then
If SH_bj(Index) = "0" Then
Call jilu("除虫", MyQQ, "为自己的" & farmlandIndex + 1 & "号农田除虫成功,经验:+" & exp)
Else
Call jilu("除虫", MyQQ, "帮助好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田除虫成功,经验:+" & exp & ",金钱:+" & money)
End If
Debug.Print "除虫：" & sum
If sum > 0 Then '等待除虫的列表
Debug.Print "除虫1：" & sum
If InStr(chuchonglb, "/" & SH_uid(Index) & "|" & farmlandIndex & "|") = 0 Then
chuchonglb = "/" & SH_uid(Index) & "|" & farmlandIndex & "|" & SH_name(Index) & "//" & czzl(Index) & "||" & chuchonglb
End If
Else
Call addsxlb(SH_uid(Index), czzl(Index)) '加入刷新列表
End If
Call tongji(3, 0, money, exp) '统计收益
Else
If bzsx = False Then
Call jilu("除虫", MyQQ, "今日帮助好友次数已达到上限（150次）已不再增加经验。")
If Val(Label45.Caption) < 150 Then Label45.Caption = 150
End If
chuchonglb = ""
bzsx = True
End If
Debug.Print chuchonglb
End If
ElseIf lx = 4 Then '锄草
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 1 Then
money = split_m(1, SH_Temp(Index), "money") '金钱
exp = split_m(1, SH_Temp(Index), "exp") '经验
sum = split_m(2, SH_Temp(Index), "weed") '剩余数量
If exp > 0 Or xzbz = 0 Or SH_bj(Index) = "0" Then
If SH_bj(Index) = "0" Then
Call jilu("锄草", MyQQ, "为自己的" & farmlandIndex + 1 & "号农田锄草成功,经验:+" & exp)
Else
Call jilu("锄草", MyQQ, "帮助好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田锄草成功,经验:+" & exp & ",金钱:+" & money)
End If
Debug.Print "除草：" & sum
If sum > 0 Then '等待锄草的列表
Debug.Print "除草1：" & sum
If InStr(chucaolb, "/" & SH_uid(Index) & "|" & farmlandIndex & "|") = 0 Then
chucaolb = "/" & SH_uid(Index) & "|" & farmlandIndex & "|" & SH_name(Index) & "//" & czzl(Index) & "||" & chucaolb
Debug.Print "除草2：" & chucaolb
End If
Debug.Print "除草3：" & chucaolb
Else
Call addsxlb(SH_uid(Index), czzl(Index)) '加入刷新列表
End If
Call tongji(3, 0, money, exp) '统计收益
Else
If bzsx = False Then
Call jilu("锄草", MyQQ, "今日帮助好友次数已达到上限（150次）已不再增加经验。")
If Val(Label45.Caption) < 150 Then Label45.Caption = 150
End If
chucaolb = ""
bzsx = True
End If
End If
Debug.Print chucaolb
ElseIf lx = 5 Then '浇水
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 1 Then
money = split_m(1, SH_Temp(Index), "money") '金钱
exp = split_m(1, SH_Temp(Index), "exp") '经验
If exp > 0 Or xzbz = 0 Or SH_bj(Index) = "0" Then
sum = split_m(2, SH_Temp(Index), "humidity") '剩余数量
If SH_bj(Index) = "0" Then
Call jilu("浇水", MyQQ, "为自己的" & farmlandIndex + 1 & "号农田浇水成功,经验:+" & exp)
Else
Call jilu("浇水", MyQQ, "帮助好友[" & SH_name(Index) & "]的" & farmlandIndex + 1 & "号农田浇水成功,经验:+" & exp & ",金钱:+" & money)
End If
Debug.Print "浇水：" & sum
If sum > 0 Then '等待浇水的列表
Debug.Print "浇水1：" & sum
If InStr(jiaoshuilb, "/" & SH_uid(Index) & "|" & farmlandIndex & "|") = 0 Then
jiaoshuilb = "/" & SH_uid(Index) & "|" & farmlandIndex & "|" & SH_name(Index) & "//" & czzl(Index) & "||" & jiaoshuilb
End If
Else
Call addsxlb(SH_uid(Index), czzl(Index)) '加入刷新列表
End If
Debug.Print jiaoshuilb
Call tongji(3, 0, money, exp) '统计收益
Else
If bzsx = False Then
Call jilu("浇水", MyQQ, "今日帮助好友次数已达到上限（150次）已不再增加经验。")
If Val(Label45.Caption) < 150 Then Label45.Caption = 150
End If
jiaoshuilb = ""
bzsx = True
End If
End If
ElseIf lx = 6 Then '翻地
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 1 Then
exp = split_m(1, SH_Temp(Index), "exp") '经验
Call jilu("翻地", MyQQ, "为自己的" & farmlandIndex + 1 & "号农田翻地成功,经验:+" & exp)
Debug.Print fandilb
If zdbz = 1 Then
If InStr(bozhonglb, "/" & Myuid & "|" & farmlandIndex & "|") = 0 Then
bozhonglb = bozhonglb & "/" & Myuid & "|" & farmlandIndex & "|" & Myxiaoyou & "//" & rzl & "||"
End If
Debug.Print "加入播种列表"
End If
Call addsxlb(Myuid, rzl) '加入刷新列表
Call tongji(5, 0, 0, exp) '统计收益
End If
ElseIf lx = 7 Then '播种
code = split_m(1, SH_Temp(Index), "code") '返回状态
farmlandIndex = split_m(1, SH_Temp(Index), "farmlandIndex") '农田ID
If code = 1 Then
exp = split_m(1, SH_Temp(Index), "exp") '经验
Call jilu("种植", MyQQ, "为自己的" & farmlandIndex + 1 & "号农田种植【" & Replace(zhonglei(SH_bj(Index), 0), "　", "") & "】成功,经验:+" & exp)
Debug.Print bozhonglb
Call addsxlb(Myuid, rzl) '加入刷新列表
Call tongji(5, 0, 0, exp) '统计收益
End If
Form1.bbi = 290
ElseIf lx = 8 Then '刷新背包
mybox = ""
If InStr(SH_Temp(Index), """cId""") > 0 Then
If InStr(SH_Temp(Index), "},{") > 0 Then
Dim temp() As String
temp = Split(SH_Temp(Index), "},{")
For i = 0 To UBound(temp())
If InStr(temp(i), "cName") > 0 Then
cId = split_m(1, temp(i), "cId")
amount = split_m(1, temp(i), "amount")
If InStr(mybox, "/" & cId & "|" & amount & "|") = 0 Then
mybox = mybox & "/" & cId & "|" & amount & "//"
End If
End If
Next i
Else
If InStr(SH_Temp(Index), "cName") > 0 Then
cId = split_m(1, SH_Temp(Index), "cId")
amount = split_m(1, SH_Temp(Index), "amount")
If InStr(mybox, "/" & cId & "|" & amount & "|") = 0 Then
mybox = mybox & "/" & cId & "|" & amount & "//"
End If
End If
End If
End If
End If
SH_Temp(Index) = ""
End If
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
Timer2.Enabled = False
QQLogin.Show vbModal, Me
End Sub
Private Sub Label34_Click()
If Label26.Caption = "" Then
If MsgBox("您还没有登录,只有登录才能使用。" & vbCrLf & "" & vbCrLf & "您是否现在进行登录？", 32 Or vbYesNo, "登录提示") = vbYes Then QQLogin.Show vbModal, Me
Exit Sub
End If
If Label34.Caption = "农场扫描" Then
If MsgBox("您确定要立即扫描所有好友的农场作物吗？" & vbCr & vbCr & "温馨提示：请勿频繁重复扫描，否则可能被农场限制甚至降级!", 32 Or vbYesNo, "扫描确认") = vbYes Then
SmTime = Time_C
csi = 0
smcs = 0
smddsj = 0
kaishi = True
Call jilu("系统", MyQQ, "正在扫描好友农场作物,并全部加入监视列表...")
Label33.Visible = True
Label34.Caption = "0/" & haoyoui
Timer5.Enabled = False
Timer5.Enabled = True
End If
ElseIf Label34.Caption = "继续扫描" Then
smddsj = 0
smcs = 0
Label33.Visible = True
Label34.Caption = csi & "/" & haoyoui
Label34.ForeColor = &H808080
Call jilu("系统", MyQQ, "农场扫描恢复成功,现在继续扫描剩余的" & haoyoui - csi & "个农场。")
Else
If MsgBox("您确定要停止扫描吗？", 32 Or vbYesNo, "停止确认") = vbYes Then
SmTime = Time_C
kaishi = False
smcs = 0
smddsj = 0
Label34.ForeColor = &H808080
Call jilu("系统", MyQQ, "停止扫描,共更新了" & csi & "位好友农场,所有作物已被监视," & blxx & "分钟后重新扫描!")
Label33.Visible = False
Label34.Caption = "农场扫描"
Call SaoMiaoINI(SmTime, csi) '保存扫描的时间
End If
End If
End Sub
Private Sub SaoMiaoINI(SmTime As Long, csi As Long) '保存扫描的时间
On Error Resume Next
Dim SmTime_temp As String, csi_temp As String
SmTime_temp = SmTime
csi_temp = csi
WritePrivateProfileString MyQQ, "SmTime", SmTime_temp, App.Path & "Config.ini"
WritePrivateProfileString MyQQ, "csi", csi_temp, App.Path & "Config.ini"
End Sub
Private Sub Timer5_Timer() '循环读取农场信息
On Error Resume Next
Dim rzl As Integer
Dim sz As String
' Debug.Print "测试"
If login = True And dengdai = False And haoyoui > 1 And XPButton21.Caption = "停止工作" And yzmqk = False Then
' If Len(touqulb) > 0 Or Len(chuchonglb) > 0 Or Len(chucaolb) > 0 Or Len(jiaoshuilb) > 0 Or Len(fandilb) > 0 Or Len(bozhonglb) > 0 Or Len(sxlb) > 0 Then Exit Sub
If smxx = 1 And haoyoui > smrs Then '扫描休息
If smcs >= smrs And smddsj = 0 Then
smddsj = Time_C
Call jilu("系统", MyQQ, "已扫描" & smrs & "个好友农场, 现在暂停扫描" & smxxsj & "分钟。")
Label33.Visible = False
Label34.Caption = "继续扫描"
Label34.ForeColor = &HFF&
Call SaoMiaoINI(smddsj, csi) '保存扫描的时间
End If
If smddsj > 0 And Time_C - smddsj >= smxxsj * 60 Then
smddsj = 0
smcs = 0
If XPButton22.Caption = "成熟列表" Then Label33.Visible = True
Label34.Caption = csi & "/" & haoyoui
Label34.ForeColor = &H808080
Call jilu("系统", MyQQ, "农场扫描休息完毕,现在继续扫描剩余的" & haoyoui - csi & "个农场。")
Call SaoMiaoINI(Time_C, csi) '保存扫描的时间
ElseIf smddsj > 0 Then
Exit Sub
End If
End If
If kaishi = False And Time_C - SmTime >= blxx * 60 Then
SmTime = Time_C
csi = 0
smcs = 0
kaishi = True
Call jilu("系统", MyQQ, "正在扫描好友农场作物,并全部加入监视列表...")
If XPButton22.Caption = "成熟列表" Then Label33.Visible = True
Label34.Caption = "0/" & haoyoui
ElseIf Smjixu = True And Time_C - SmTime < blxx * 45 And csi > 0 And csi < haoyoui Then
Smjixu = False
SmTime = Time_C
smcs = 0
kaishi = True
Call jilu("系统", MyQQ, "正在扫描上次未扫描完的" & haoyoui - csi & "个好友农场作物,并全部加入监视列表...")
If XPButton22.Caption = "成熟列表" Then Label33.Visible = True
Label34.Caption = csi & "/" & haoyoui
End If
If csi >= haoyoui And kaishi = True Then
SmTime = Time_C
kaishi = False
csi = 0
smcs = 0
smddsj = 0
Label34.ForeColor = &H808080
Call jilu("系统", MyQQ, "扫描完成,共更新了" & haoyoui & "位好友农场,所有作物已被监视," & blxx & "分钟后重新扫描!")
Label33.Visible = False
Label34.Caption = "农场扫描"
Call SaoMiaoINI(SmTime, csi) '保存扫描的时间
End If
If kaishi = True Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend where userid <> " & Myuid & " and xz = True order by Time ,exp desc", conn, 1, 3
If rs.RecordCount > 0 Then
If Len(rs.Fields("Time")) < 8 Or DateDiff("s", rs.Fields("Time"), Now()) > 60 Then ' and DateDiff("s", sendtime, Now) >= 1
With rs
.Update
!time = Now()
.Update
End With
sxdl = rs.Fields("userId")
xli = xli + 1 '巡逻次数
rzl = rs.Fields("zl")
Call update_From(rzl)
End If
csi = csi + 1
If smxx = 1 And haoyoui > smrs Then smcs = smcs + 1
Label34.Caption = csi & "/" & haoyoui
End If
rs.Close '关闭数据库
Set rs = Nothing
End If
End If
End Sub
Private Sub Timer3_Timer() '刷新我的农场
On Error Resume Next
Dim K As Integer, level As Long, jy As String
Dim tem1 As String, tem2 As String
Dim temp As Long
Dim xiangtong As Boolean
Dim rc As Integer
' Debug.Print "QQ校友：" & Myxiaoyou; " QQ空间：" & Myqzone
If login = False Or XPButton21.Caption <> "停止工作" Then Exit Sub
Timer3.Interval = 5000
Timer3.Enabled = False
Timer3.Enabled = True
If Myuid = 0 Then
Call update_MyFrom
Label2.Caption = "加载中..."
Exit Sub
End If
level = dengji(Myexp)
tem1 = Myexp - ((level - 1) * level) * 100 - (level) * 200
tem2 = (level + 1) * 200
For II = 1 To 4
If Len(tem1) < 4 Then tem1 = " " & tem1
Next II
jy = tem1 & " / " & tem2
If Len(Myxiaoyou) = 0 Then Myxiaoyou = "校友用户"
Label2.Caption = Myxiaoyou '名称
Label4.Caption = level '等级
Label6.Caption = Mymoney '金钱
Label8.Caption = Trim(jy) '经验
'显示农场信息
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM Farm where userid=" & Myuid & " order by Location", conn, 1, 1
rc = rs.RecordCount
If rc = 0 Then
If sxdl <> Myuid Then
List2.Clear
List2.AddItem "正在加载中..."
Call update_MyFrom
End If
Else
If rs.RecordCount <> List2.ListCount Then
List2.Clear
ElseIf List2.ListCount > 0 Then
xiangtong = True
End If
If Time_C - rs.Fields("MTime") >= mysx Then
If sxdl <> Myuid Then
sxdl = Myuid
Call update_MyFrom
End If
End If
While Not rs.EOF
K = K + 1
Dim kk As String
Dim mm As String
kk = Replace(Format(rs.Fields("k"), "00"), "00", " 0")
mm = Replace(Format(rs.Fields("m"), "00"), "00", "0 ")
If kk > 0 Then
If rs.Fields("m") = rs.Fields("l") Then
If xiangtong = True Then
List2.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 所剩无几"
Else
List2.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 所剩无几"
End If
Else
If xiangtong = True Then
List2.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已经成熟"
Else
List2.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已经成熟"
End If
End If
Else
If rs.Fields("Kind") = 0 Then
If xiangtong = True Then
List2.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")"
Else
List2.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")"
End If
Else
temp = rs.Fields("q") - (DateDiff("s", DateSerial(1970, 1, 1), Now()) - shicha)
' Debug.Print temp
If temp > 0 And temp <= 45 Then
zdbs = True
grsxsd = 4
End If
If xiangtong = True Then
List2.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " " & time_m(rs.Fields("q"))
Else
List2.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " " & time_m(rs.Fields("q"))
End If
End If
End If
rs.MoveNext
'DoEvents
Wend
End If
rs.Close '关闭数据库
Set rs = Nothing
End Sub
Private Sub update_From(zl As Integer) '立即更新农场
On Error Resume Next
If sxdl > 0 And login = True And dengdai = False And yzmqk = False Then
sendid = Wi() + 1
hqid(sendid) = sxdl
hqtemp(sendid) = ""
myhqtime = Now
sendtime = Now
Winsock2(sendid).Tag = sxdl
nczl(sendid) = zl
If Proxy = 1 Then '使用代理
Winsock2(sendid).Close
Winsock2(sendid).RemoteHost = Proxy_IP
Winsock2(sendid).RemotePort = Proxy_DK
Winsock2(sendid).Connect
Else
Winsock2(sendid).Close
If zl = 1 Then
Winsock2(sendid).RemoteHost = "nc.qzone.qq.com"
Else
Winsock2(sendid).RemoteHost = "nc.xiaoyou.qq.com"
End If
Winsock2(sendid).RemotePort = 80
Winsock2(sendid).Connect
End If
End If
End Sub
Sub update_MyFrom() '立即更新我的农场
On Error Resume Next
If login = True And dengdai = False And Abs(shicha) > 0 And yzmqk = False Then
sendid = Wi() + 1
hqid(sendid) = Myuid
hqtemp(sendid) = ""
myhqtime = Now
sendtime = Now
myi = sendid
Winsock2(sendid).Tag = sxdl
If Proxy = 1 Then '使用代理
Winsock2(sendid).Close
Winsock2(sendid).RemoteHost = Proxy_IP
Winsock2(sendid).RemotePort = Proxy_DK
Winsock2(sendid).Connect
Else
Winsock2(sendid).Close
If Farmqk = True Then
If Len(Myxiaoyou) = 0 Then
Winsock2(sendid).RemoteHost = "happyfarm.xiaoyou.qq.com"
nczl(sendid) = 0
Debug.Print "开始获取QQ校友名字"
ElseIf Len(Myqzone) = 0 Then
Winsock2(sendid).RemoteHost = "happyfarm.qzone.qq.com"
nczl(sendid) = 1
Debug.Print "开始获取QQ空间名字"
Else
gxmyi = gxmyi + 1
If gxmyi > 10 Then
gxmyi = 0
Winsock2(sendid).RemoteHost = "happyfarm.qzone.qq.com"
nczl(sendid) = 1
Else
Winsock2(sendid).RemoteHost = "happyfarm.xiaoyou.qq.com"
nczl(sendid) = 0
End If
End If
Else
Winsock2(sendid).RemoteHost = "happyfarm.qzone.qq.com"
nczl(sendid) = 1
End If
Winsock2(sendid).RemotePort = 80
Winsock2(sendid).Connect
End If
End If
End Sub
'↓ ↓ ↓ 获取农场信息↓ ↓ ↓ ======================
Private Sub Winsock2_Connect(Index As Integer)
On Error Resume Next
Dim strCommand As String
Dim posttem As String
Dim proxytemp As String
Randomize Timer
If Proxy = 1 Then '使用代理
If myi = Index Or hqid(Index) = Myuid Then
If nczl(sendid) = 1 Then
proxytemp = "http://happyfarm.qzone.qq.com"
Else
proxytemp = "http://happyfarm.xiaoyou.qq.com"
End If
Else
If nczl(sendid) = 1 Then
proxytemp = "http://nc.qzone.qq.com"
Else
proxytemp = "http://nc.xiaoyou.qq.com"
End If
End If
End If
If myi = Index Or hqid(Index) = Myuid Then
posttem = "farmKey=" & Farmkey_cx & "&farmTime=" & Time_Cx
strCommand = "POST " & proxytemp & "/api.php?mod=user&act=run HTTP/1.1" & vbCrLf
Else
strCommand = "GET " & proxytemp & "/cgi-bin/cgi_farm_index?mod=user&act=run" & yzmcode & "&ownerId=" & hqid(Index) & " HTTP/1.1" & vbCrLf
End If
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
If Proxy = 1 And Len(Basic) > 0 Then strCommand = strCommand & "Proxy-Authorization: Basic " & Basic & vbCrLf
If myi = Index Or hqid(Index) = Myuid Then
If nczl(sendid) = 1 Then
strCommand = strCommand & "Host: happyfarm.qzone.qq.com" & vbCrLf
Else
strCommand = strCommand & "Host: happyfarm.xiaoyou.qq.com" & vbCrLf
End If
Else
If nczl(sendid) = 1 Then
strCommand = strCommand & "Host: nc.qzone.qq.com" & vbCrLf
Else
strCommand = strCommand & "Host: nc.xiaoyou.qq.com" & vbCrLf
End If
End If
If myi = Index Or hqid(Index) = Myuid Then
strCommand = strCommand & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
End If
strCommand = strCommand & "Referer: http://appimg.qq.com/happyfarm/module/Main_v_" & flashbb & ".swf" & vbCrLf
strCommand = strCommand & "x-flash-version: " & flash & vbCrLf
strCommand = strCommand & "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" & vbCrLf
strCommand = strCommand & "Connection: close" & vbCrLf
If myi = Index Or hqid(Index) = Myuid Then
strCommand = strCommand & "Content-Length: " & Len(posttem) & vbCrLf
End If
strCommand = strCommand & "Cookie: " & FarmCookies & vbCrLf
' strCommand = strCommand & "Cookie: uin=" & login_uid & "; skey=" & login_skey & "; pst=" & pst - 5 & ";" & vbCrLf
strCommand = strCommand & vbCrLf
If myi = Index Or hqid(Index) = Myuid Then
strCommand = strCommand & posttem
End If
Winsock2(Index).SendData strCommand
yzmcode = "" '清空验证码
End Sub
Private Sub Winsock2_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
ReDim str(bytesTotal - 1) As Byte
Winsock2(Index).GetData str, vbArray + vbByte
hqtemp(Index) = hqtemp(Index) & UTF8_Decode(str)
End Sub
Private Sub Winsock2_Close(Index As Integer) '更新农场信息
On Error Resume Next
Winsock2(Index).Close
Dim fanwei As String, tem1 As String, tem2 As String, sum As Integer, tem3 As String
Dim tudi() As String, hyname As String, dog As String, gl As Integer, tem_exp As Long, xz As Boolean
Dim rc As Integer, rzl As Integer, b As Integer
Dim pst_temp As Long
Dim gx As Boolean
If Len(hqtemp(Index)) > 0 Then
'记录QQ服务器时间
If InStr(hqtemp(Index), "Set-Cookie: pst=") > 0 Then
tem1 = Split(hqtemp(Index), "Set-Cookie: pst=")(1)
pst_temp = Val(Split(tem1, ";")(0))
If pst_temp > 0 Then pst = pst_temp
pst_temp = Time_C - pst_temp
If pst_temp > 0 Then shicha = pst_temp
Call shichaini(shicha) '更新时差
gx = True
End If
If InStr(hqtemp(Index), """time""") > 0 Then
pst_temp = Val(split_m(2, hqtemp(Index), "time"))
Debug.Print pst_temp
If pst_temp > 0 Then pst = pst_temp
pst_temp = Time_C - pst_temp
If pst_temp > 0 Then shicha = pst_temp
Call shichaini(shicha) '更新时差
gx = True
End If
If gxshicha = False Then
If gx = True Then
Dim temp As String
temp = Val(DateDiff("s", DateSerial(1970, 1, 1), Format(FromUnixTime(Time_Cx, 8), "yyyy-M-d 23:59:59")) + 1)
If Len(temp) = 10 Then
If gxTime <> Val(temp) Then
Label45.Caption = 0
WritePrivateProfileString MyQQ, "BmCs", "0", App.Path & "Config.ini"
End If
gxTime = Val(temp)
WritePrivateProfileString MyQQ, "BmTime", temp, App.Path & "Config.ini"
gxshicha = True
End If
End If
End If
If InStr(hqtemp(Index), "请重新登录") > 0 Or InStr(hqtemp(Index), "u8BF7u91CDu65B0u767Bu5F55") > 0 Then '登录超时
diaoxiani = diaoxiani + 1
' If diaoxiani = 1 And InStr(bbname, "Beta") > 0 Then Call jilu("调试", MyQQ, "获取农场时出现超时!")
If diaoxiani >= 5 And login = True And jcwork = False Then
hqtemp(Index) = ""
jctemp = ""
jcwork = True
Timer18.Interval = 5000
Timer18.Enabled = True
If Proxy = 1 Then '使用代理
Winsock7.Close
Winsock7.RemoteHost = Proxy_IP
Winsock7.RemotePort = Proxy_DK
Winsock7.Connect
Else
Winsock7.Close
Winsock7.RemoteHost = "xiaoyou.qq.com"
Winsock7.RemotePort = 80
Winsock7.Connect
End If
diaoxiani = 0
Exit Sub
End If
Else
diaoxiani = 0
End If
If InStr(hqtemp(Index), ":""validateCode") > 0 Then '需要输入验证码
yzmlx.lx = -1
yzmlx.uID = hqid(Index)
yzmlx.rzl = nczl(Index)
Call xyyzm '弹出验证码
Debug.Print "请输入验证码" & " 次数：" & yzmcsi
Exit Sub
End If
tem1 = Split(hqtemp(Index), "farmlandStatus"":[")(1)
fanwei = Split(tem1, "],""items"":")(0) '获取范围
tudi = Split(fanwei, "},{")
For i = 0 To UBound(tudi())
Dim a As Integer, q As Long, K As Integer, m As Integer, l As Integer, touqu As Boolean, buzu As Boolean
a = split_m(1, tudi(i), "a") '种类
If a > 0 Then
q = split_m(1, tudi(i), "q")
If q > 0 Then
q = q + zhonglei(a, 1) '播种时间
End If
K = split_m(1, tudi(i), "k") '产量
l = split_m(1, tudi(i), "l") '最低产量
m = split_m(1, tudi(i), "m") '当前剩下
b = split_m(1, tudi(i), "b") '作物状态
Dim tqtemp As String
tqtemp = split_m(1, tudi(i), "n")
' Debug.Print tqtemp
If InStr(tqtemp, Myuid & ":") > 0 Or (K < 0 Or m < 0 Or l < 0) Then
touqu = 1
Else
touqu = 0
End If
If l > 0 And l = m Then
buzu = 1
Else
buzu = 0
End If
Else '空地
q = 0 '播种时间
K = 0 '产量
l = 0 '最低产量
m = 0 '当前剩下
touqu = 0
buzu = 0
End If
dog = split_m(2, hqtemp(Index), "isHungry") '检查是否有狗狗
If dog = "0" Then
gl = 1
Else
gl = 0
End If
tem_exp = split_m(1, hqtemp(Index), "exp")
If myi = Index Then
Dim tem_uId As Long, tem_money As Long
Dim tem_name As String
tem_uId = split_m(1, hqtemp(Index), "uId")
tem_name = vbUnEscape(split_m(3, hqtemp(Index), "userName"))
tem_money = split_m(1, hqtemp(Index), "money")
myi = -1
fzsxsb = 0 '清空防止刷新个人农场失败参数
If Len(tem_name) = 0 And InStr(hqtemp(Index), "userName"":null") > 0 Then
tem_name = "农场用户"
End If
If tem_uId > 0 Then
Myuid = tem_uId
hyname = tem_name
If Farmqk = True Then
If nczl(Index) = 0 Then
Myxiaoyou = tem_name
If Len(Myqzone) = 0 Then
Rqzonei = Rqzonei + 1
If Rqzonei <= 10 Then Call update_MyFrom
End If
Else
Myqzone = tem_name
End If
Else
Myxiaoyou = tem_name
Myqzone = tem_name
End If
Myexp = tem_exp '我的经验
Mymoney = tem_money '我的金钱
hqid(Index) = tem_uId
Winsock2(Index).Tag = tem_uId
If Len(Myxiaoyou) = 0 Then Myxiaoyou = "我的农场"
End If
If lqlw = False Then
If (split_m(1, hqtemp(Index), "yellowlevel") > 0 And split_m(2, hqtemp(Index), "yellowstatus") > 0) Or InStr(bbname, "Beta") > 0 Then
templqlw = ""
If Proxy = 1 Then '使用代理
Winsock10.Close
Winsock10.RemoteHost = Proxy_IP
Winsock10.RemotePort = Proxy_DK
Winsock10.Connect
Else
Winsock10.Close
If Farmqk = True Then
Winsock10.RemoteHost = "happyfarm.xiaoyou.qq.com"
Else
Winsock10.RemoteHost = "happyfarm.qzone.qq.com"
End If
Winsock10.RemotePort = 80
Winsock10.Connect
End If
Else
lqlw = True
End If
End If
End If
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend where userId=" & hqid(Index), conn, 1, 3
rzl = rs.Fields("zl")
If rs.RecordCount > 0 Then
hyname = vbUnEscape(rs.Fields("userName"))
xz = rs.Fields("xz")
With rs
.Update
!time = Now()
If Farmqk = True Then
If nczl(Index) = 0 Then
If Myuid = hqid(Index) And Myuid > 0 Then !userName = vbEscape(Myxiaoyou)
End If
Else
If Myuid = hqid(Index) And Myuid > 0 Then !userName = vbEscape(Myxiaoyou)
End If
If Myuid = hqid(Index) And Myuid > 0 Then !money = Mymoney
If tem_exp > 0 Then
!exp = tem_exp
End If
.Update
End With
ElseIf Myuid = hqid(Index) And Myuid > 0 Then
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId=" & Myuid, conn, 1, 3
rc = rs1.RecordCount
If rc = 0 Then
If Len(Myxiaoyou) = 0 Then Myxiaoyou = vbEscape("我的农场")
xz = True
With rs
.AddNew
!userId = Myuid
If Farmqk = True Then
If nczl(Index) = 0 Then
!userName = Myxiaoyou
End If
Else
!userName = Myxiaoyou
End If
!exp = Myexp
!money = Mymoney
!time = Now()
.Update
End With
Call jiazai("exp", True) '加载数据
End If
rs1.Close '关闭数据库
Set rs1 = Nothing
End If
rs.Close '关闭数据库
Set rs = Nothing
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM Farm where userId=" & hqid(Index) & " and Location=" & i + 1, conn, 1, 3
If rs.RecordCount > 0 Then
With rs
.Update
!kind = Abs(a)
!K = Abs(K)
!l = Abs(l)
!m = Abs(m)
!q = Abs(q)
!touqu = touqu
!buzu = buzu
!MTime = Time_C()
!gl = gl
!xz = xz
!zl = rzl
.Update
End With
Else
With rs
.AddNew
!userId = hqid(Index)
!Location = i + 1
!kind = Abs(a)
!K = Abs(K)
!l = Abs(l)
!m = Abs(m)
!q = Abs(q)
!touqu = touqu
!buzu = buzu
!MTime = Time_C()
!gl = gl
!xz = xz
!zl = rzl
.Update
End With
End If
rs.Close '关闭数据库
Set rs = Nothing
If (XPButton21.Caption = "停止工作" Or gzxxing = True) And xz = True Then
tem3 = split_m(2, tudi(i), "p")
If hqid(Index) <> Myuid And zdtq = 1 And ((fqgg = 1 And gl = 0) Or fqgg = 0) Then
If (K > 0 And m > l) And touqu = False Then '等待偷取的列表
If InStr(touqulb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
touqulb = touqulb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
End If
If zdsg = 1 And hqid(Index) = Myuid Then
If l > 0 Then '等待收获的列表
If InStr(shouhuolb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
shouhuolb = shouhuolb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
End If
If (zdsc = 1 Or zdbsc = 1) And Abs(m) = 0 Then
Dim yxsc As Boolean
If hqid(Index) = Myuid Then
If zdsc = 1 Then
yxsc = True
End If
ElseIf zdbsc = 1 And (xzbz = 0 Or (xzbz = 1 And bzsx = False)) Then
yxsc = True
End If
If yxsc = True Then
Dim G As String
G = split_m(1, tudi(i), "g")
If Len(G) = 1 And Val(G) > 0 Then '等待除虫的列表
If InStr(chuchonglb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
chuchonglb = chuchonglb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
End If
End If
If (zdcc = 1 Or zdbcc = 1) And Abs(m) = 0 Then
Dim yxcc As Boolean
If hqid(Index) = Myuid Then
If zdcc = 1 Then
yxcc = True
End If
ElseIf zdbcc = 1 And (xzbz = 0 Or (xzbz = 1 And bzsx = False)) Then
yxcc = True
End If
If yxcc = True Then
Dim f As String
f = split_m(1, tudi(i), "f")
If Len(f) = 1 And Val(f) > 0 Then '等待锄草的列表
If InStr(chucaolb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
chucaolb = chucaolb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
End If
End If
If (zdjs = 1 Or zdbjs = 1) And Abs(m) = 0 Then
Dim yxjs As Boolean
If hqid(Index) = Myuid Then
If zdjs = 1 Then
yxjs = True
End If
ElseIf zdbjs = 1 And (xzbz = 0 Or (xzbz = 1 And bzsx = False)) Then
yxjs = True
End If
If yxjs = True Then
Dim h As String
h = split_m(1, tudi(i), "h")
If Len(h) = 1 And Val(h) = 0 Then '等待浇水的列表
If InStr(jiaoshuilb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
jiaoshuilb = jiaoshuilb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
End If
End If
If zdbz = 1 And hqid(Index) = Myuid Then
If hqid(Index) = Myuid And a > 0 And b = 7 Then '等待翻地的列表
If InStr(fandilb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
fandilb = fandilb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
End If
If hqid(Index) = Myuid And a = 0 And q = 0 And sexp = False Then '等待播种的列表
If InStr(bozhonglb, "/" & hqid(Index) & "|" & i & "|") = 0 Then
bozhonglb = bozhonglb & "/" & hqid(Index) & "|" & i & "|" & hyname & "//" & rzl & "||"
End If
Debug.Print "加入播种列表"
End If
End If
End If
Next i
hqtemp(Index) = ""
If Winsock2(Index).Tag = Myuid Then
Call Timer3_Timer
End If
If Winsock2(Index).Tag = hqid(Index) Then
sxdl = 0
Winsock2(Index).Tag = ""
If listfarmid = hqid(Index) Then
level = dengji(tem_exp)
tem1 = tem_exp - ((level - 1) * level) * 100 - (level) * 200
tem2 = (level + 1) * 200
For II = 1 To 4
If Len(tem1) < 4 Then tem1 = " " & tem1
Next II
Call vsListView1.SubItemSet(listfarmid, 2, level, 0)
Call vsListView1.SubItemSet(listfarmid, 3, tem1 & " / " & tem2, 0)
Call Timer4_Timer
End If
End If
End If
End Sub
Private Sub Winsock10_Connect() '自动领取礼物
On Error Resume Next
Dim strCommand As String
Dim posttem As String
Dim proxytemp As String
Randomize Timer
If Proxy = 1 Then '使用代理
If Farmqk = True Then
proxytemp = "http://happyfarm.xiaoyou.qq.com"
Else
proxytemp = "http://happyfarm.qzone.qq.com"
End If
End If
posttem = "farmKey=" & Farmkey_cx & "&farmTime=" & Time_Cx
strCommand = "POST " & proxytemp & "/api.php?mod=Feast&act=getPackage HTTP/1.1" & vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
If Proxy = 1 And Len(Basic) > 0 Then strCommand = strCommand & "Proxy-Authorization: Basic " & Basic & vbCrLf
If Farmqk = True Then
strCommand = strCommand & "Host: happyfarm.xiaoyou.qq.com" & vbCrLf
Else
strCommand = strCommand & "Host: happyfarm.qzone.qq.com" & vbCrLf
End If
strCommand = strCommand & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
strCommand = strCommand & "Referer: http://appimg.qq.com/happyfarm/module/Main_v_" & flashbb & ".swf" & vbCrLf
strCommand = strCommand & "x-flash-version: " & flash & vbCrLf
strCommand = strCommand & "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" & vbCrLf
strCommand = strCommand & "Connection: close" & vbCrLf
strCommand = strCommand & "Content-Length: " & Len(posttem) & vbCrLf
strCommand = strCommand & "Cookie: " & FarmCookies & vbCrLf
' strCommand = strCommand & "Cookie: uin=" & login_uid & "; skey=" & login_skey & "; pst=" & pst - 5 & ";" & vbCrLf
strCommand = strCommand & vbCrLf
strCommand = strCommand & posttem
Winsock10.SendData strCommand
End Sub
Private Sub Winsock10_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
ReDim str(bytesTotal - 1) As Byte
Winsock10.GetData str, vbArray + vbByte
templqlw = templqlw & UTF8_Decode(str)
End Sub
Private Sub Winsock10_Close()
On Error Resume Next
Winsock10.Close
If Len(templqlw) > 0 Then
If InStr(templqlw, "direction") > 0 Then
Call jilu("黄钻", MyQQ, "领取礼包：成功领取黄钻每日礼包!")
End If
lqlw = True
End If
templqlw = ""
End Sub
'====================== ↑↑↑ 获取农场信息 ↑↑↑
Private Sub Winsock7_Connect()
On Error Resume Next
Dim strCommand As String
Dim proxytemp As String
Randomize Timer
If Proxy = 1 Then '使用代理
proxytemp = "http://xiaoyou.qq.com"
End If
strCommand = "GET " & proxytemp & "/index.php?mod=home HTTP/1.1" & vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
If Proxy = 1 And Len(Basic) > 0 Then strCommand = strCommand & "Proxy-Authorization: Basic " & Basic & vbCrLf
strCommand = strCommand & "Host: xiaoyou.qq.com" & vbCrLf
strCommand = strCommand & "Referer: http://xiaoyou.qq.com/index.php?mod=useredit&act=baseinfoedit" & vbCrLf
strCommand = strCommand & "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" & vbCrLf
strCommand = strCommand & "Connection: Keep-Alive" & vbCrLf
strCommand = strCommand & "Cookie: " & FarmCookies & vbCrLf
' strCommand = strCommand & "Cookie: uin=" & login_uid & "; skey=" & login_skey & "; pst=" & pst - 5 & ";" & vbCrLf
strCommand = strCommand & vbCrLf
Winsock7.SendData strCommand
End Sub
Private Sub Winsock7_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
ReDim str(bytesTotal - 1) As Byte
Winsock7.GetData str, vbArray + vbByte
jctemp = jctemp & UTF8_Decode(str)
If InStr(jctemp, "好友日志</a>") > 0 Then
Timer18.Enabled = False
jcwork = False
Call jilu("系统", MyQQ, "农场可能被临时限制,故休息" & xzsj & "分钟后自动重试!")
XPButton21.Caption = "解除休息"
XPButton21.ForeColor = &HFF&
dengdai = True
ddi = 0
jctemp = ""
Winsock7.Close
ElseIf InStr(jctemp, "location: /index.html?ref=http") > 0 Then
Timer18.Enabled = False
jcwork = False
Call jilu("系统", MyQQ, "登录失效，请重新登录，有可能是服务器维护或异地登录导致!")
Call wdl
MsgBox "登录失效，请重新登录，有可能是服务器维护或异地登录导致!", 48, "提醒"
If Form1.Visible = False Then
FormTop Me.hwnd, True
FormTop Me.hwnd, False
Form1.Show
End If
jctemp = ""
Winsock7.Close
End If
End Sub
'加载好友名单↓ ↓ ↓ ======================
Private Sub Timer1_Timer() '加载好友名单
On Error Resume Next
Dim sum As Integer
Dim tempname As String
If login = False Or shicha = 0 Then Exit Sub
If jiazaiing = False And vsListView1.Count < 1 And Len(Text1.Text) = 0 Then
With vsListView1
Call .Clear '清空
Call .ItemAdd(vsListView1.Count, "正在", 0, 0)
Call .SubItemSet(vsListView1.Count - 1, 1, "加载中...", 0)
.ItemChecked(0) = True
End With
If tbhy = False Then Label2.Caption = "加载中..."
If tbhy = False Then Label10.Caption = "加载中..."
jiazaiing = True
Timer1.Interval = 1000
End If
If shicha > 0 And zxjiazai = False Then
If sdsx = False Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend", conn, 1, 1
sum = rs.RecordCount
tempname = rs.Fields("userName")
If InStr(tempname, "u") = 0 Then sdsx = True
rs.Close '关闭数据库
Set rs = Nothing
End If
If Farmqk = False Then sxlblx = 1
If (sdsx = True And Farmqk = True) Or (sum = 0 And Farmqk = True) Or (tbhy = True And Farmqk = True) Then
zxjiazai = True
Timer1.Enabled = False
Timer1.Interval = 8000
Timer1.Enabled = True
login_temp = ""
If sxlblx = 1 Then
If qzonets = False Then
qzonets = True
Call jilu("系统", MyQQ, "正在更新《QQ空间》好友...")
End If
Else
If xiaoyouts = False Then
xiaoyouts = True
Call jilu("系统", MyQQ, "正在更新《QQ校友》好友...")
End If
End If
If Proxy = 1 Then '使用代理
Winsock1.Close
Winsock1.RemoteHost = Proxy_IP
Winsock1.RemotePort = Proxy_DK
Winsock1.Connect
Else
Winsock1.Close
If sxlblx = 1 Then
Winsock1.RemoteHost = "happyfarm.qzone.qq.com"
If qzonets = False Then
qzonets = True
Call jilu("系统", MyQQ, "正在更新《QQ空间》好友...")
End If
Else
Winsock1.RemoteHost = "happyfarm.xiaoyou.qq.com"
If xiaoyouts = False Then
xiaoyouts = True
Call jilu("系统", MyQQ, "正在更新《QQ校友》好友...")
End If
End If
Winsock1.RemotePort = 80
Winsock1.Connect
End If
Else
sxlblx = 1
If sdsx = False Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend where zl = 1", conn, 1, 1
sum = rs.RecordCount
rs.Close '关闭数据库
Set rs = Nothing
End If
' Debug.Print "正在加载QQ空间好友!"
If sum = 0 Or sdsx = True Then
zxjiazai = True
Timer1.Enabled = False
Timer1.Interval = 8000
Timer1.Enabled = True
login_temp = ""
If qzonets = False Then
qzonets = True
Call jilu("系统", MyQQ, "正在更新《QQ空间》好友名单...")
End If
If Proxy = 1 Then '使用代理
Winsock1.Close
Winsock1.RemoteHost = Proxy_IP
Winsock1.RemotePort = Proxy_DK
Winsock1.Connect
Else
Winsock1.Close
Winsock1.RemoteHost = "happyfarm.qzone.qq.com"
Winsock1.RemotePort = 80
Winsock1.Connect
End If
Else
Timer1.Enabled = False
Call jiazai("exp", True) '加载数据
jiazaiing = False
zxjiazai = True
Call Timer4_Timer
End If
End If
End If
End Sub
Private Sub Winsock1_Connect()
On Error Resume Next
Dim strCommand As String
Dim posttem As String
Dim proxytemp As String
Randomize Timer
If Proxy = 1 Then '使用代理
If sxlblx = 1 Then
proxytemp = "http://happyfarm.qzone.qq.com"
Else
proxytemp = "http://happyfarm.xiaoyou.qq.com"
End If
End If
posttem = "refresh=true&farmTime=" & Time_Cx & "&farmKey=" & Farmkey_cx & yzmcode
strCommand = "POST " & proxytemp & "/api.php?mod=friend HTTP/1.1" & vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
If Proxy = 1 And Len(Basic) > 0 Then strCommand = strCommand & "Proxy-Authorization: Basic " & Basic & vbCrLf
If sxlblx = 1 Then
strCommand = strCommand & "Host: happyfarm.qzone.qq.com" & vbCrLf
Else
strCommand = strCommand & "Host: happyfarm.xiaoyou.qq.com" & vbCrLf
End If
strCommand = strCommand & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
strCommand = strCommand & "x-flash-version: " & flash & vbCrLf
strCommand = strCommand & "Referer: http://appimg.qq.com/happyfarm/module/Main_v_" & flashbb & ".swf" & vbCrLf
strCommand = strCommand & "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" & vbCrLf
strCommand = strCommand & "Connection: close" & vbCrLf
strCommand = strCommand & "Content-Length: " & Len(posttem) & vbCrLf
strCommand = strCommand & "Cookie: " & FarmCookies & vbCrLf
' strCommand = strCommand & "Cookie: uin=" & login_uid & "; skey=" & login_skey & "; pst=" & pst - 5 & ";" & vbCrLf
strCommand = strCommand & vbCrLf
strCommand = strCommand & posttem
Winsock1.SendData strCommand
yzmcode = "" '清空验证码
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
ReDim str(bytesTotal - 1) As Byte
Winsock1.GetData str, vbArray + vbByte
login_temp = login_temp & UTF8_Decode(str)
End Sub
Private Sub Winsock1_Close() '更新好友队列
On Error Resume Next
Dim temp() As String, sum As Integer
Dim level As Long, tem1 As String, tem2 As String, rd As Integer
Dim temp1() As String
Dim userId As Long, userName As String, exp As Long, money As Long
Dim rc As Integer, rzl As Integer
Dim pass As Boolean
Randomize Timer
Winsock1.Close
If Len(login_temp) > 0 Then
If InStr(login_temp, "请重新登录") > 0 Or InStr(login_temp, "u8BF7u91CDu65B0u767Bu5F55") > 0 Then '登录超时
diaoxiani = diaoxiani + 1
' If diaoxiani = 1 And InStr(bbname, "Beta") > 0 Then Call jilu("调试", MyQQ, "获取好友列表出现超时!")
If diaoxiani >= 5 And login = True And jcwork = False Then
login_temp = ""
jctemp = ""
jcwork = True
Timer18.Interval = 5000
Timer18.Enabled = True
If Proxy = 1 Then '使用代理
Winsock7.Close
Winsock7.RemoteHost = Proxy_IP
Winsock7.RemotePort = Proxy_DK
Winsock7.Connect
Else
Winsock7.Close
Winsock7.RemoteHost = "xiaoyou.qq.com"
Winsock7.RemotePort = 80
Winsock7.Connect
End If
diaoxiani = 0
Exit Sub
End If
Else
diaoxiani = 0
End If
If InStr(login_temp, ":""validateCode") > 0 Then '需要输入验证码
If sxlblx = 1 Then
yzmlx.lx = 5
Else
yzmlx.lx = 6
End If
Call xyyzm '弹出验证码
Debug.Print "请输入验证码" & " 次数：" & yzmcsi
Exit Sub
End If
If InStr(login_temp, "}]") > 0 Then
Winsock1.Close
If InStr(login_temp, "Set-Cookie: pst=") > 0 Then
Dim shicha1 As Long
tem1 = Split(login_temp, "Set-Cookie: pst=")(1)
shicha1 = Val(Split(tem1, ";")(0))
If shicha1 > 0 Then pst = shicha1
shicha1 = DateDiff("s", DateSerial(1970, 1, 1), Now()) - shicha1
If shicha1 > 0 Then shicha = shicha1
End If
If InStr(login_temp, "},") = 0 And InStr(login_temp, "}]") > 0 Then
temp = Split(login_temp, "}]")
sum = UBound(temp())
pass = True
ElseIf InStr(login_temp, "},") > 0 Then
login_temp = Replace(login_temp, """,""", ",""")
login_temp = Replace(login_temp, """:""", ":""")
login_temp = Split(login_temp, "}]")(0)
temp = Split(login_temp, "},")
sum = UBound(temp())
pass = True
End If
Debug.Print sum
If pass = True Then
' Set rs = New ADODB.Recordset
' rs.CursorLocation = adUseServer
' rs.Open "delete * FROM friend", conn, 1, 3
' Set rs = Nothing
If tbhy = True Then
Randomize Timer
rd = Int(Rnd * 2000)
End If
If sxlblx = 1 Then
For i = 0 To sum
temp1 = Split(temp(i), ",""")
If UBound(temp1()) >= 6 Then
userId = Split(temp1(0), "userId"":")(1)
userName = Split(temp1(1), "userName:""")(1)
exp = Split(temp1(5), "exp"":")(1)
money = Split(temp1(6), "money"":")(1)
If i = 0 Then
Timer4.Enabled = False
Timer4.Interval = 100
Timer4.Enabled = True
End If
If userId > 0 Then
rzl = 0
rc = 0
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId=" & userId, conn, 1, 3
rc = rs1.RecordCount
rzl = rs1.Fields("zl")
If rc > 0 And rzl = 1 Then
If rs1.Fields("zl") = 1 Then
With rs1
.Update
If Len(userName) > 0 Then !userName = userName
!exp = exp
!money = money
If tbhy = True Then !bj = rd
.Update
End With
End If
ElseIf rc = 0 Then
If Len(userName) = 0 Then userName = vbEscape("农场玩家")
With rs1
.AddNew
!userId = userId
!userName = userName
!exp = exp
!money = money
If tbhy = True Then !bj = rd
!zl = 1
.Update
End With
End If
rs1.Close '关闭数据库
Set rs1 = Nothing
End If
End If
Next i
If tbhy = True Then
Debug.Print "同步中：" & rd
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where zl = 1 and bj <> " & rd, conn, 1, 3
rc = rs1.RecordCount
If rc > 0 Then
While Not rs1.EOF
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM Farm where userId=" & rs1.Fields("userid"), conn, 1, 3
rs2.Close
Set rs2 = Nothing
rs1.MoveNext
Wend
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM friend where bj <> " & rd, conn, 1, 3
rs2.Close
Set rs2 = Nothing
End If
rs1.Close
Set rs1 = Nothing
If Farmqk = False Then
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId = " & Myuid, conn, 1, 3
If rs1.RecordCount > 1 Then
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM friend where userId = " & Myuid, conn, 1, 3
rs2.Update
rs2.Close
Set rs2 = Nothing
End If
rs1.Close
Set rs1 = Nothing
Set rs3 = New ADODB.Recordset
rs3.CursorLocation = adUseServer
rs3.Open "SELECT * FROM friend where userId = " & Myuid, conn, 1, 3
rc = rs3.RecordCount
If rc = 0 Then
If Len(Myxiaoyou) = 0 Then Myxiaoyou = "农场玩家"
With rs3
.Update
.AddNew
!userId = Myuid
!userName = vbEscape(Myxiaoyou)
!exp = Myexp
!money = Mymoney
!time = Now()
.Update
End With
End If
rs3.Close
Set rs3 = Nothing
End If
End If
Call jiazai("exp", True) '加载数据
jiazaiing = False
sdsx = False
tbhy = False
Call jilu("系统", MyQQ, "《QQ空间》好友名单,更新完毕!")
If Farmqk = True Then
Call jilu("系统", MyQQ, "空间和校友重复名单已自动筛选过滤完成!")
End If
gxsbi = 0
Else
For i = 0 To sum
temp1 = Split(temp(i), ",""")
If UBound(temp1()) >= 6 Then
userId = Split(temp1(0), "userId"":")(1)
userName = Split(temp1(1), "userName:""")(1)
exp = Split(temp1(5), "exp"":")(1)
money = Split(temp1(6), "money"":")(1)
If i = 0 Then
Timer4.Enabled = False
Timer4.Interval = 100
Timer4.Enabled = True
End If
If userId > 0 Then
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId=" & userId, conn, 1, 3
If rs1.RecordCount > 0 Then
With rs1
.Update
If Len(userName) > 0 Then !userName = userName
!exp = exp
!money = money
If tbhy = True Then !bj = rd
.Update
End With
Else
If Len(userName) = 0 Then userName = vbEscape("农场玩家")
With rs1
.AddNew
!userId = userId
!userName = userName
!exp = exp
!money = money
If tbhy = True Then !bj = rd
.Update
End With
End If
rs1.Close '关闭数据库
Set rs1 = Nothing
End If
End If
Next i
If tbhy = True Then
Debug.Print "同步中：" & rd
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where bj <> " & rd, conn, 1, 3
rc = rs1.RecordCount
If rc > 0 Then
While Not rs1.EOF
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM Farm where userId=" & rs1.Fields("userid"), conn, 1, 3
rs2.Close
Set rs2 = Nothing
rs1.MoveNext
Wend
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM friend where bj <> " & rd, conn, 1, 3
rs2.Close
Set rs2 = Nothing
End If
rs1.Close
Set rs1 = Nothing
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId = " & Myuid, conn, 1, 3
If rs1.RecordCount > 1 Then
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseServer
rs2.Open "delete * FROM friend where userId = " & Myuid, conn, 1, 3
rs2.Update
rs2.Close
Set rs2 = Nothing
End If
rs1.Close
Set rs1 = Nothing
Set rs3 = New ADODB.Recordset
rs3.CursorLocation = adUseServer
rs3.Open "SELECT * FROM friend where userId = " & Myuid, conn, 1, 3
rc = rs3.RecordCount
If rc = 0 Then
If Len(Myxiaoyou) = 0 Then Myxiaoyou = "农场玩家"
With rs3
.Update
.AddNew
!userId = Myuid
!userName = vbEscape(Myxiaoyou)
!exp = Myexp
!money = Mymoney
!time = Now()
.Update
End With
End If
rs3.Close
Set rs3 = Nothing
If Farmqk = False Then
sdsx = False
tbhy = False
End If
End If
Call jiazai("exp", True) '加载数据
jiazaiing = False
If Farmqk = True Then
sxlblx = 1
zxjiazai = False
Timer1.Enabled = False
Timer1.Interval = 100
Timer1.Enabled = True
End If
gxsbi = 0
Call jilu("系统", MyQQ, "《QQ校友》好友名单,更新完毕!")
End If
Else
gxsbi = gxsbi + 1
If gxsbi >= 10 Then
If sxlblx = 1 Then
If sdsx = False Then Call jilu("系统", MyQQ, "《QQ空间》好友,更新失败,可能是服务器繁忙或你还没有开通!")
Else
If sdsx = False Then Call jilu("系统", MyQQ, "《QQ校友》好友,更新失败,可能是服务器繁忙或你被临时限制!")
End If
If Farmqk = False Then
sdsx = False
tbhy = False
End If
Call jiazai("exp", True) '加载数据
jiazaiing = False
gxsbi = 0
Else
zxjiazai = False '重新加载
End If
Debug.Print "测试1:加载失败了吗？"
End If
ElseIf InStr(login_temp, "[]") > 0 Then
If sxlblx = 1 Then
Call jiazai("exp", True) '加载数据
jiazaiing = False
sdsx = False
tbhy = False
gxsbi = 0
Call jilu("系统", MyQQ, "《QQ空间》好友名单,更新完毕!")
Else
sxlblx = 1
zxjiazai = False
Timer1.Enabled = False
Timer1.Interval = 100
Timer1.Enabled = True
gxsbi = 0
Call jilu("系统", MyQQ, "《QQ校友》好友名单,更新完毕!")
End If
Else
gxsbi = gxsbi + 1
If gxsbi >= 10 Then
If sxlblx = 1 Then
If sdsx = False Then Call jilu("系统", MyQQ, "《QQ空间》好友,更新失败,可能是服务器繁忙或你还没有开通!")
Else
If sdsx = False Then Call jilu("系统", MyQQ, "《QQ校友》好友,更新失败,可能是服务器繁忙或你被临时限制!")
End If
If Farmqk = False Then
sdsx = False
tbhy = False
End If
Call jiazai("exp", True) '加载数据
jiazaiing = False
gxsbi = 0
Else
zxjiazai = False '重新加载
End If
Debug.Print "测试2:加载失败了吗？"
End If
login_temp = ""
End If
End Sub
Private Sub vsListView1_ColumnClick(Column As Integer) '排序
On Error Resume Next
If login = True Then
If Column = 4 Or Column = 3 Then
If exppx = False Then
exppx = True
Else
exppx = False
End If
Call jiazai("exp", exppx) '加载经验降序
ElseIf Column = 5 Then
If moneypx = False Then
moneypx = True
Else
moneypx = False
End If
Call jiazai("money", moneypx) '加载金钱降序
End If
End If
End Sub
Private Sub vsListView1_ItemClick(Item As Integer) '按方向键
On Error Resume Next
If Item >= 0 Then
If dianji <> Item Then
dianji = Item
Call Timer4_Timer
End If
shangcitime = Time_C '记录上次操作时间
End If
End Sub
Private Sub Timer4_Timer() '显示好友信息
On Error Resume Next
Dim K As Integer
Dim xiangtong As Boolean
Dim rc As Integer
If login = False Or XPButton21.Caption <> "停止工作" Then Exit Sub
If sfbs = 1 Then
Timer4.Interval = bs2
Else
Timer4.Interval = 10000
End If
Timer4.Enabled = False
Timer4.Enabled = True
listfarmid = Val(vsListView1.SubItemText(dianji, 5)) '好友ID
listfarmzl = Val(vsListView1.SubItemText(dianji, 7)) '好友种类
Label10.Caption = vsListView1.SubItemText(dianji, 1) '名称
Label12.Caption = Trim(vsListView1.SubItemText(dianji, 2)) '等级
Label14.Caption = Val(vsListView1.SubItemText(dianji, 4)) '金钱
Label16.Caption = Trim(vsListView1.SubItemText(dianji, 3)) '经验
'显示农场信息
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM Farm where userid=" & listfarmid & " order by Location", conn, 1, 1
rc = rs.RecordCount
If rc = 0 Then
If sxdl <> listfarmid Then
List1.Clear
Timer10.Interval = 200
Timer10.Enabled = False
Timer10.Enabled = True
List1.AddItem "正在加载中..."
End If
Else
If rs.RecordCount <> List1.ListCount Then
List1.Clear
ElseIf List1.ListCount > 0 Then
xiangtong = True
End If
If Time_C - rs.Fields("MTime") >= 30 And NowListID <> (dianji + 1) Then
Timer10.Interval = 500
Timer10.Enabled = False
Timer10.Enabled = True
Else
Timer10.Enabled = False
End If
NowListID = dianji + 1
While Not rs.EOF
K = K + 1
Dim kk As String
Dim mm As String
kk = Replace(Format(rs.Fields("k"), "00"), "00", " 0")
mm = Replace(Format(rs.Fields("m"), "00"), "00", "0 ")
If kk > 0 Then
If rs.Fields("m") = rs.Fields("l") Then
If xiangtong = True Then
List1.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 所剩无几"
Else
List1.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 所剩无几"
End If
Else
If rs.Fields("touqu") = True Then
If xiangtong = True Then
List1.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已偷过"
Else
List1.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已偷过"
End If
Else
If xiangtong = True Then
List1.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已经成熟"
Else
List1.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " 已经成熟"
End If
End If
End If
Else
If rs.Fields("Kind") = 0 Then
If xiangtong = True Then
List1.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")"
Else
List1.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")"
End If
Else
If xiangtong = True Then
List1.List(K - 1) = K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " " & time_m(rs.Fields("q"))
Else
List1.AddItem K & "、" & zhonglei(rs.Fields("Kind"), 0) & "(" & kk & "/" & mm & ")" & " " & time_m(rs.Fields("q"))
End If
End If
End If
rs.MoveNext
'DoEvents
Wend
End If
rs.Close '关闭数据库
Set rs = Nothing
End Sub
Private Sub Timer6_Timer()
On Error Resume Next
If login = True And dengdai = False And XPButton21.Caption = "停止工作" And yzmqk = False Then
Dim temp As String, tem1 As String, tempuid As Long, tempid As Integer, tempname As String
Dim jzcz As Boolean, rzl As Integer
If shicha = 0 Then Exit Sub
If Time_C - login_time <= 4 Then Exit Sub
' If qzxx = 1 Then '强制休息
'
' If czi > blxxrs And czsj = 0 Then
' czsj = time_c()
' End If
'
' If czsj > 0 And time_c - czsj >= xxsj * 60 Then
' czsj = 0
' czi = 0
' ElseIf czsj > 0 Then
' jzcz = True
' End If
'
' End If
If xzcz = 1 Then '限制次数
If sccz = 0 Then
sccz = Time_C()
End If
If Time_C - sccz <= 60 And ljcz >= xzcs Then
jzcz = True
ElseIf Time_C - sccz > 60 Then
sccz = Time_C()
ljcz = 0
End If
End If
If jzcz = False Then
If Len(touqulb) > 0 Then '自动偷取
temp = Split(touqulb, "//")(0)
tempuid = Val(Replace(Split(temp, "|")(0), "/", ""))
tempid = Val(Split(temp, "|")(1))
tempname = Split(temp, "|")(2)
rzl = Split(Split(touqulb, "//")(1), "||")(0)
If tempuid > 0 Then
ljcz = ljcz + 1 '本分钟累计操作次数
' czi = czi + 1 '累计操作次数
touqulb = Replace(touqulb, temp & "//" & rzl & "||", "")
If InStr(deletelist, "" & tempuid & "") = 0 Then
Call SendHttp(2, tempuid, tempid, tempname, "1", rzl)
Debug.Print "开始偷取" & tempuid & " " & rzl & " " & tempid
End If
End If
End If
If Len(chuchonglb) > 0 Then '自动除虫
temp = Split(chuchonglb, "//")(0)
tempuid = Val(Replace(Split(temp, "|")(0), "/", ""))
tempid = Val(Split(temp, "|")(1))
tempname = Split(temp, "|")(2)
rzl = Split(Split(chuchonglb, "//")(1), "||")(0)
If tempuid > 0 Then
chuchonglb = Replace(chuchonglb, temp & "//" & rzl & "||", "")
' czi = czi + 1 '累计操作次数
ljcz = ljcz + 1 '本分钟累计操作次数
If tempuid = Myuid Then
Call SendHttp(3, tempuid, tempid, tempname, "0", rzl)
Else
Call SendHttp(3, tempuid, tempid, tempname, "1", rzl)
End If
End If
End If
If Len(chucaolb) > 0 Then '自动锄草
temp = Split(chucaolb, "//")(0)
tempuid = Val(Replace(Split(temp, "|")(0), "/", ""))
tempid = Val(Split(temp, "|")(1))
tempname = Split(temp, "|")(2)
rzl = Split(Split(chucaolb, "//")(1), "||")(0)
If tempuid > 0 Then
chucaolb = Replace(chucaolb, temp & "//" & rzl & "||", "")
' czi = czi + 1 '累计操作次数
ljcz = ljcz + 1 '本分钟累计操作次数
If tempuid = Myuid Then
Call SendHttp(4, tempuid, tempid, tempname, "0", rzl)
Else
Call SendHttp(4, tempuid, tempid, tempname, "1", rzl)
End If
End If
End If
If Len(jiaoshuilb) > 0 Then '自动浇水
temp = Split(jiaoshuilb, "//")(0)
tempuid = Val(Replace(Split(temp, "|")(0), "/", ""))
tempid = Val(Split(temp, "|")(1))
tempname = Split(temp, "|")(2)
rzl = Split(Split(jiaoshuilb, "//")(1), "||")(0)
If tempuid > 0 Then
jiaoshuilb = Replace(jiaoshuilb, temp & "//" & rzl & "||", "")
' czi = czi + 1 '累计操作次数
ljcz = ljcz + 1 '本分钟累计操作次数
If tempuid = Myuid Then
Call SendHttp(5, tempuid, tempid, tempname, "0", rzl)
Else
Call SendHttp(5, tempuid, tempid, tempname, "1", rzl)
End If
End If
End If
If Len(sxlb) > 0 Then '自动刷新
Dim T() As String
Dim TempTime As Long
T = Split(sxlb, ",")
For i = 0 To UBound(T()) - 1
TempTime = Val(Split(Split(T(i), "\")(0), "//")(1))
If Time_C - TempTime >= 5 Then
temp = Split(sxlb, "//")(0)
tempuid = Val(Replace(temp, "/", ""))
rzl = Split(Split(sxlb, "\")(1), "||")(0)
If Val(tempuid) > 0 Then
sxlb = Replace(sxlb, temp & "//" & TempTime & "\" & rzl & "||,", "")
If InStr(sxlb, "/" & tempuid & "//") = 0 Then
sxdl = tempuid
Call update_From(rzl)
If tempuid = Myuid Then
fzsxsb = Time_C '防止个人农场刷新失败
End If
End If
Exit For
End If
End If
Next i
End If
End If
' If bzsx = True Then '清空帮助上限
'
' If DateDiff("n", Now, DateAdd("d", 1, Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " 00:15:00")) = 1440 Then
' bzsx = False
' lqlw = False
' End If
'
' End If
End If
End Sub
Private Sub Timer7_Timer() '循环列出成熟列表
On Error Resume Next
Dim rzl As Integer
If login = True And dengdai = False And haoyoui > 1 And (zdtq = 1 Or zdsg = 1) And (XPButton21.Caption = "停止工作" Or gzxxing = True) And yzmqk = False Then
If XPButton21.Caption = "停止工作" Then
Dim g1 As String, g2 As String
If fqgg = 1 Then
g1 = " and gl = 0"
g2 = " and (gl = 0 or userid=" & Myuid & ")"
End If
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
If zdtq = 1 And zdsg = 1 Then
rs.Open "SELECT Top 15 * FROM Farm where Kind > 0 and " & Time_Cx & " - q >= 0 and " & Time_Cx & " - q <= 1800 and xz = True and touqu = 0 and buzu = 0 " & g2 & " order by Kind desc", conn, 1, 1
ElseIf zdtq = 0 And zdsg = 1 Then
rs.Open "SELECT Top 15 * FROM Farm where Kind > 0 and " & Time_Cx & " - q >= 0 and touqu = 0 and buzu = 0 and userid=" & Myuid & " order by Kind desc", conn, 1, 1
ElseIf zdtq = 1 And zdsg = 0 Then
rs.Open "SELECT Top 15 * FROM Farm where Kind > 0 and " & Time_Cx & " - q >= 0 and " & Time_Cx & " - q <= 1800 and xz = True and touqu = 0 and buzu = 0 and userid <> " & Myuid & g1 & " order by Kind desc", conn, 1, 1
End If
If rs.RecordCount > 0 Then
While Not rs.EOF
rzl = rs.Fields("zl")
If InStr(sxlb, "/" & rs.Fields("userid") & "//") = 0 And InStr(touqulb, "/" & rs.Fields("userid") & "|") = 0 And InStr(shouhuolb, "/" & rs.Fields("userid") & "|") = 0 And InStr(deletelist, "" & rs.Fields("userid") & "") = 0 Then
' sxlb = sxlb & "/" & rs.Fields("userid") & "//" & rzl & "||"
sxlb = sxlb & "/" & rs.Fields("userid") & "//" & Time_C - 6 & "\" & rzl & "||,"
Debug.Print "成熟列表：" & rs.Fields("userid") & " " & rs.Fields("Location")
Debug.Print sxlb
Debug.Print rs.Fields("q")
End If
rs.MoveNext
DoEvents
Wend
End If
rs.Close '关闭数据库
Set rs = Nothing
ElseIf gzxxing = True Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM Farm where " & Time_Cx & " - q >= 0 and touqu = 0 and buzu = 0 and userid=" & Myuid & " order by Kind desc", conn, 1, 1
If rs.RecordCount > 0 Then
If InStr(shouhuolb, "/" & Myuid & "|") = 0 Then
sxdl = Myuid
rzl = rs.Fields("zl")
Call update_From(rzl)
End If
End If
rs.Close '关闭数据库
Set rs = Nothing
End If
End If
End Sub
Private Sub xiemdb(lx As Integer, uID As Long, id As Integer) '写入数据库
On Error Resume Next
If lx = 1 Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM Farm where userId=" & uID & " and Location=" & id, conn, 1, 3
If rs.RecordCount > 0 Then
With rs
.Update
!touqu = 1
.Update
End With
End If
rs.Close
Set rs = Nothing
ElseIf lx = 2 Then
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "delete * FROM Farm where userId=" & uID, conn, 1, 3
rs.Close
Set rs = Nothing
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "delete * FROM friend where userId=" & uID, conn, 1, 3
rs.Close
Set rs = Nothing
Debug.Print "删除成功：" & uID
Call jiazai("exp", True) '重载数据
If InStr(deletelist, "" & uID & "") = 0 Then
deletelist = deletelist & "" & uID & ""
End If
End If
End Sub
'以下是托盘的源代码
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
On Error Resume Next
Dim Result As Long
Dim cEvent As Single
cEvent = X / Screen.TwipsPerPixelX
Select Case cEvent
Case LeftDbClick '左键双击
If yzmqk = True Then
yzm.Visible = False
Form1.WindowState = 0
FormTop Me.hwnd, True
FormTop Me.hwnd, False
Form1.Show
Call xyyzm '弹出验证码
Else
Form1.WindowState = 0
FormTop Me.hwnd, True
FormTop Me.hwnd, False
Form1.Show
End If
SetProcessWorkingSetSize GetCurrentProcess(), -1&, -1&
If vsListView2.Visible = True Then
Timer20.Enabled = False
Timer20.Interval = 100
Timer20.Enabled = True
End If
Case RightDown
If Form1.Visible = True Then
Main.xsjm.Caption = "隐藏界面"
Else
Main.xsjm.Caption = "显示界面"
End If
If XPButton21.Caption = "开始工作" Then
Main.tzgz.Caption = "开始工作"
Else
Main.tzgz.Caption = "停止工作"
End If
' 显示菜单
Me.PopupMenu Main.yjcd
End Select
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = vbMinimized Then
If XPButton21.Caption = "开始工作" And login = True And dengdai = False Then
If MsgBox("伴侣目前还没有开始工作，是否现在开启？", 32 Or vbYesNo, "开始确认") = vbYes Then
XPButton21.Caption = "停止工作"
End If
End If
Me.Visible = False
If MyQQ > 0 Then
TrayTip Form1, "登录用户：" & Myxiaoyou & "(" & MyQQ & ")" & vbCrLf & "-----------------------------" & vbCrLf & "更多源码下载：http://www.h876.com"
TrayBalloon Form1, "登录用户：" & Myxiaoyou & "(" & MyQQ & ")" & vbCrLf & "-----------------------------" & vbCrLf & "当前版本：" & bbid & " " & bbname & " " & bbrq & "" & vbCrLf & "-----------------------------" & vbCrLf & "使用交流：http://www.h876.com", "QQ伴侣", NIIF_INFO
Else
TrayTip Form1, "登录用户：未登录(******)" & vbCrLf & "-----------------------------" & vbCrLf & "更多源码下载：http://www.h876.com"
TrayBalloon Form1, "当前版本：" & bbid & " " & bbname & " " & bbrq & "" & vbCrLf & "-----------------------------" & vbCrLf & "使用交流：http://www.h876.com", "QQ伴侣", NIIF_INFO
End If
End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
If tssj = False And UnloadMode <> 2 Then
If MsgBox("确定要退出软件吗？", 32 Or vbYesNo, "退出确认") = vbNo Then
Cancel = True
Exit Sub
End If
End If
If Label34.Caption <> "农场扫描" And Label34.Caption <> "继续扫描" Then
Call SaoMiaoINI(Time_C, csi) '保存扫描的时间
End If
If tssj = False And UnloadMode <> 2 Then
If InStr(webtem, "biaoti=|") > 0 Then
Dim biaoti As String, neirong As String, URL As String, tem1 As String
Form1.Visible = False
tem1 = Split(webtem, "biaoti=|")(1)
biaoti = Split(tem1, "|")(0)
tem1 = Split(webtem, "neirong=|")(1)
neirong = Split(tem1, "|")(0)
neirong = Replace(neirong, "n", vbCrLf)
tem1 = Split(webtem, "URL=|")(1)
URL = Split(tem1, "|")(0)
If MsgBox(neirong, 32 Or vbOKCancel, biaoti) = vbOK Then
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
objIE.Navigate (URL)
End If
End If
End If
tssj = True
Set conn = Nothing
TrayRemoveIcon '删触任务栏图标
' Call SetWindowLong(hwnd, GWL_WNDPROC, OldWndProc)
If yzmqk = True Then Unload yzm
Unload QQLogin
Unload Main
Unload Me
End
End Sub
Private Sub Image1_Click()
On Error Resume Next
If login = True Then
If vsListView1.Count > 1 Or chazhaoguo = True And Len(Label27.Caption) > 0 Then
If Len(Text1.Text) > 0 Then
Call chazhao(Text1.Text)
Else
Call jiazai("exp", True)
End If
End If
shangcitime = Time_C '记录上次操作时间
End If
End Sub
Private Sub Text1_Change()
If login = True Then
Timer9.Enabled = True
End If
End Sub
Private Sub Timer9_Timer()
On Error Resume Next
Timer9.Enabled = False
If vsListView1.Count > 1 Or chazhaoguo = True And Len(Label27.Caption) > 0 Then
If Len(Text1.Text) > 0 Then
Call chazhao(Text1.Text)
Else
Call jiazai("exp", True)
End If
If XPButton22.Caption = "好友列表" Then
Call XPButton22_Click
End If
shangcitime = Time_C '记录上次操作时间
End If
End Sub
' ====================== ↑↑↑ 加载好友名单
Private Sub jiazai(lx As String, px As Boolean) '重新排序
On Error Resume Next
Dim ListI As Integer
Dim paixu As String
Dim rc As Long
gxhy = False
haoyoui = 0
If px = True Then paixu = " desc"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend order by " & lx & paixu, conn, 1, 3
vsListView1.Clear
rc = rs.RecordCount
If rc > 0 And rc < 9999 Then
While Not rs.EOF
With vsListView1
level = dengji(Val(rs.Fields("exp")))
tem1 = Val(rs.Fields("exp")) - ((level - 1) * level) * 100 - (level) * 200
'tem1 = Abs(Myexp - ((level - 1) * (level - 1) + (level - 3)) * 100 - (level + 1) * 200)
tem2 = (level + 1) * 200
For K = 1 To 4
If Len(tem1) < 4 Then tem1 = " " & tem1
Next K
jy = tem1 & " / " & tem2
ListI = ListI + 1
Call .ItemAdd(vsListView1.Count, ListI, 0, 0)
Call .SubItemSet(vsListView1.Count - 1, 1, vbUnEscape(rs.Fields("userName")), 0)
Call .SubItemSet(vsListView1.Count - 1, 2, level, 0)
Call .SubItemSet(vsListView1.Count - 1, 3, jy, 0)
Call .SubItemSet(vsListView1.Count - 1, 4, rs.Fields("money"), 0)
Call .SubItemSet(vsListView1.Count - 1, 5, rs.Fields("userId"), 0)
If rs.Fields("xz") = True Then
.ItemChecked(vsListView1.Count - 1) = True
Call .SubItemSet(vsListView1.Count - 1, 6, "True", 0)
If gxhy = False Then haoyoui = haoyoui + 1
Else
Call .SubItemSet(vsListView1.Count - 1, 6, "", 0)
End If
Call .SubItemSet(vsListView1.Count - 1, 7, rs.Fields("zl"), 0)
End With
rs.MoveNext
DoEvents
Wend
If haoyoui > keysum Then
If keysum > 0 Then
ReDim Preserve keyu(haoyoui)
Else
ReDim keyu(haoyoui)
End If
keysum = haoyoui
End If
End If
gxhy = True
rs.Close '关闭数据库
Set rs = Nothing
End Sub
Private Sub chazhao(shuju As String) '查找数据库
On Error Resume Next
Dim ListI As Integer
Dim rc As Long
shuju = LCase(vbEscape(shuju))
chazhaoguo = True
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT * FROM friend where userName like '%" & shuju & "%' order by exp desc", conn, 1, 3
vsListView1.Clear
rc = rs.RecordCount
If rc > 0 And rc < 1000 Then
While Not rs.EOF
If Len(rs.Fields("userName")) > 0 And InStr(vbUnEscape(rs.Fields("userName")), vbUnEscape(shuju)) > 0 Then
With vsListView1
level = dengji(Val(rs.Fields("exp")))
tem1 = Val(rs.Fields("exp")) - ((level - 1) * level) * 100 - (level) * 200
'tem1 = Abs(Myexp - ((level - 1) * (level - 1) + (level - 3)) * 100 - (level + 1) * 200)
tem2 = (level + 1) * 200
For K = 1 To 4
If Len(tem1) < 4 Then tem1 = " " & tem1
Next K
jy = tem1 & " / " & tem2
ListI = ListI + 1
Call .ItemAdd(vsListView1.Count, ListI, 0, 0)
Call .SubItemSet(vsListView1.Count - 1, 1, vbUnEscape(rs.Fields("userName")), 0)
Call .SubItemSet(vsListView1.Count - 1, 2, level, 0)
Call .SubItemSet(vsListView1.Count - 1, 3, jy, 0)
Call .SubItemSet(vsListView1.Count - 1, 4, rs.Fields("money"), 0)
Call .SubItemSet(vsListView1.Count - 1, 5, rs.Fields("userId"), 0)
If rs.Fields("xz") = True Then
.ItemChecked(vsListView1.Count - 1) = True
Call .SubItemSet(vsListView1.Count - 1, 6, "True", 0)
Else
Call .SubItemSet(vsListView1.Count - 1, 6, "", 0)
End If
Call .SubItemSet(vsListView1.Count - 1, 7, rs.Fields("zl"), 0)
End With
End If
rs.MoveNext
DoEvents
Wend
dianji = 0
Call Timer4_Timer
End If
rs.Close '关闭数据库
Set rs = Nothing
End Sub
Private Sub xiufu_Click()
On Error Resume Next
Dim myqq_temp As String
If Label26.Caption = "" Then
If MsgBox("您还没有登录,只有登录才能使用。" & vbCrLf & "" & vbCrLf & "您是否现在进行登录？", 32 Or vbYesNo, "登录提示") = vbYes Then QQLogin.Show vbModal, Me
Else
If MsgBox("欢迎使用《QQ伴侣数据库异常修复工具》，请您在使用前先阅读以下说明：" & vbCrLf & _
"-----------------------------------------------------------------" & vbCrLf & _
"1、本工具主要修复农场作物显示异常，比如一直显示“已收割”；" & vbCrLf & vbCrLf & _
"2、修复后所有好友作物信息将会丢失(影响倒计时)，需要重新扫描获取；" & vbCrLf & _
"-----------------------------------------------------------------" & vbCrLf & vbCrLf & _
"温馨提示：如果您的QQ伴侣没有出现异常无需修复。" & vbCrLf & vbCrLf & _
"您是否要立即修复QQ伴侣数据库？", 64 Or vbYesNo, "修复确认") = vbYes Then
myqq_temp = MyQQ '记录要修复的QQ
Call SaoMiaoINI(0, 0) '保存扫描的时间
Call wdl '退出登录
Kill Main.SysPath & "Profile_v1_" & myqq_temp & ".db"
If Dir(Main.SysPath & "Profile_v1_" & myqq_temp & ".db") = "" Then
MsgBox "恭喜你，修复成功，请重新登录！", 64, "成功提示"
Else
MsgBox "修复失败，请进入系统盘手工删除：" & vbCrLf & Main.SysPath & "Profile_v1_" & myqq_temp & ".db 这个文件", 48, "失败提示"
End If
QQLogin.Timer1.Enabled = True
QQLogin.Show vbModal, Me
End If
End If
End Sub
Private Sub XPButton21_Click()
If XPButton21.Caption = "停止工作" Then
XPButton21.Caption = "开始工作"
XPButton21.ForeColor = &HFF&
MsgBox "软件已停止工作,一切操作将自动暂停!", 64, "提示"
ElseIf XPButton21.Caption = "开始工作" Then
XPButton21.ForeColor = &H8000&
XPButton21.Caption = "停止工作"
MsgBox "软件工作已重新启动!", 64, "提示"
ElseIf XPButton21.Caption = "解除休息" Then
XPButton21.Caption = "停止工作"
XPButton21.ForeColor = &H8000&
If gzxxing = True Then
gzys = 0
gzxxing = False
MsgBox "已恢复为正常工作状态!", 64, "提示"
ElseIf dengdai = True Then
ddi = 0
dengdai = False
XPButton21.ForeColor = &H8000&
XPButton21.Caption = "停止工作"
MsgBox "已停止休息重试尝试!", 64, "提示"
End If
End If
End Sub
Sub wdl() '未登录处理
On Error Resume Next
If Label34.Caption <> "农场扫描" And Label34.Caption <> "继续扫描" Then
Call SaoMiaoINI(Time_C, csi) '保存扫描的时间
End If
Smjixu = False
keysum = 0
keyjl = 0
keyutemp = ""
Label26.Caption = ""
Label26.Visible = False
Label27.Visible = True
MyQQ = 0
Myuid = 0
csi = 0
login_uid = ""
login_skey = ""
Myexp = 0
Mymoney = 0
vsListView1.Clear
List1.Clear
List2.Clear
login = False
jiazaiing = False
zxjiazai = False
Set conn = Nothing
Main.Caption = "Mainload"
ddi = 0
dengdai = False
gzys = 0
pingi = 0
haoyoui = 0
gxhy = False
zzpanelkey = ""
sxlblx = 0
SmTime = 0
kaishi = False
touqulb = ""
chuchonglb = ""
chucaolb = ""
jiaoshuilb = ""
sxlb = ""
shouhuolb = ""
fandilb = ""
bozhonglb = ""
mybox = ""
gxsbi = 0
Rqzonei = 0
xiaoyouts = False
qzonets = False
lqlw = False
Label36.Caption = 0
Label38.Caption = 0
Label40.Caption = 0
Label45.Caption = 0
Label33.Visible = False
Label34.Caption = "农场扫描"
Label34.ForeColor = &H808080
If vsListView2.Visible = True Then
vsListView2.Visible = False
vsListView2.Clear
vsListView1.Visible = True
XPButton22.Caption = "成熟列表"
End If
End Sub
Private Sub shezhi_Click()
On Error Resume Next
Dim cz As Boolean
If Label26.Caption = "" Then
If MsgBox("您还没有登录,只有登录才能使用。" & vbCrLf & "" & vbCrLf & "您是否现在进行登录？", 32 Or vbYesNo, "登录提示") = vbYes Then QQLogin.Show vbModal, Me
Else
Form2.Visible = False
'基本设置
Form2.Check1.value = zdsg '是否自动收割
Form2.Check3.value = zdsc '是否自动杀虫
Form2.Check4.value = zdcc '是否自动锄草
Form2.Check2.value = zdjs '是否自动浇水
Form2.Check9.value = zdbz '是否自动播种
Form2.Check5.value = zdtq '是否自动收割
Form2.Check7.value = zdbsc '是否自动杀虫
Form2.Check8.value = zdbcc '是否自动锄草
Form2.Check6.value = zdbjs '是否自动浇水
Form2.Check10.value = xzbz '是否限制满150次帮助自动停止帮忙
Form2.Check15.value = fqgg '是否放弃狗狗
'高级设置
Form2.Text1.Text = blpl '扫描每个好友农场的频率
Form2.Text2.Text = blxx '搜索每轮好友后自动休息
Form2.Text3.Text = mypl '自己的农场操作时间间隔
Form2.Text4.Text = hypl '好友的农场操作时间间隔
Form2.Text5.Text = mysx '刷新自己农场的时间间隔
Form2.Text6.Text = lbsx '更新好友列表的时间间隔
Form2.Text7.Text = xzsj '农场被临时限制自动休息
Form2.Check14.value = zdxx '是否自动休息
Form2.Text8.Text = gzsj '工作时间
Form2.Text9.Text = xxsj '休息时间
Form2.Check11.value = smxx '扫描休息
Form2.Text10.Text = smrs '扫描人数
Form2.Text11.Text = smxxsj '扫描休息时间
Form2.Text11.Text = smxxsj '扫描休息时间
Form2.Combo3.ListIndex = yzmts '验证码提示方式
If Form2.Combo1.ListCount = 0 Then
Dim k_temp As String
Dim kind_temp() As String
If Val(kind_sum) > 0 Then
For i = 0 To Val(kind_sum)
kind_temp = Split(kind(i), ",")
Form2.Combo1.AddItem kind_temp(0) & " / " & kind_temp(3) & "级 / " & "￥" & kind_temp(4)
Next i
End If
End If
File1.Refresh
If File1.ListCount > 0 Then
Form2.Combo2.Clear
For i = 0 To File1.ListCount - 1
If shengyin = File1.List(i) Then cz = True
If InStr(LCase(File1.List(i)), ".wav") > 0 And FileLen(App.Path & "sound" & File1.List(i)) < 1001024 Then
Form2.Combo2.AddItem File1.List(i)
End If
Next i
If cz = True Then
Form2.Combo2.Text = shengyin
Else
Form2.Combo2.ListIndex = 0
End If
End If
Form2.Combo1.ListIndex = bzzl '播种作物种类
Form2.Show vbModal, Me
End If
End Sub
Private Sub Timer15_Timer() ' 防止加速软件
On Error Resume Next
If login = False Then Exit Sub
If jiasui = 0 Or jiasui > 300 Then
jiasui = 1
jstime = Time_C
Else
jiasui = jiasui + 1
If jiasui - (Time_C - jstime) >= 15 Then
Call wdl '未登录处理
MsgBox "请重新登录,您可能使用了加速软件,或调整了本地时间! ", 64, "提醒"
End If
End If
End Sub
Private Sub Timer17_Timer() '自动等待
On Error Resume Next
If dengdai = False Then Exit Sub
ddi = ddi + 1
If ddi >= xzsj * 60 Then
ddi = 0
dengdai = False
XPButton21.ForeColor = &H8000&
XPButton21.Caption = "停止工作"
Call jilu("系统", MyQQ, "临时限制休息完毕,正在重试中...")
End If
End Sub
Private Sub XPButton22_Click()
If vsListView1.Visible = False Then
vsListView1.Visible = True
vsListView2.Visible = False
XPButton22.Caption = "成熟列表"
Frame3.Caption = "好友列表"
Label30.Visible = True
' Text1.Enabled = True
If kaishi = True Then Label33.Visible = True
Label34.Visible = True
Else
vsListView1.Visible = False
vsListView2.Visible = True
XPButton22.Caption = "好友列表"
Frame3.Caption = "成熟倒计时 (最先成熟的99个作物)"
Label30.Visible = False
' Text1.Enabled = False
Timer20.Enabled = False
Timer20.Interval = 100
Timer20.Enabled = True
' Call Timer20_Timer
Label33.Visible = False
Label34.Visible = False
End If
End Sub
Private Sub Timer20_Timer() '显示成熟列表
On Error Resume Next
If login = True And Form1.Visible = True Then
Dim i As Integer
Dim hyname As String
Dim g1 As String
If fqgg = 1 Then
g1 = " and gl = 0"
End If
Timer20.Enabled = False
Timer20.Interval = 10000
Timer20.Enabled = True
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open "SELECT Top 99 * FROM Farm where (Kind > 0 and q > 0 " & g1 & " and ((" & Time_Cx & " - q >= 0 and " & Time_Cx & " - q <= 15) or q - " & Time_Cx & " >= 0)) and xz = True and touqu = 0 and buzu = 0 or userid=" & Myuid & " order by q", conn, 1, 1
If rs.RecordCount > 0 Then
MatureSum = rs.RecordCount
If MatureSum > 99 Then MatureSum = 99
While Not rs.EOF
If i <= 99 Then
Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseServer
rs1.Open "SELECT * FROM friend where userId=" & rs.Fields("userid"), conn, 1, 1
hyname = vbUnEscape(rs1.Fields("userName"))
rs1.Close '关闭数据库
Set rs1 = Nothing
Mature(i).uID = rs.Fields("userid")
Mature(i).name = hyname
Mature(i).Location = rs.Fields("Location")
Mature(i).kind = rs.Fields("Kind")
Mature(i).q = rs.Fields("q")
Mature(i).zl = rs.Fields("zl")
End If
rs.MoveNext
DoEvents
i = i + 1
Wend
Else
MatureSum = 0
End If
rs.Close '关闭数据库
Set rs = Nothing
End If
End Sub
Private Sub Timer21_Timer() '显示成熟列表
On Error Resume Next
If login = True And XPButton22.Caption = "好友列表" And Form1.Visible = True Then
If MatureSum = 0 Then
vsListView2.Clear
ElseIf MatureSum > vsListView2.Count Then
For i = 1 To MatureSum - vsListView2.Count
With vsListView2
Call .ItemAdd(vsListView2.Count, "", 0, 0)
Call .SubItemSet(vsListView2.Count - 1, 1, "", 0)
Call .SubItemSet(vsListView2.Count - 1, 2, "", 0)
Call .SubItemSet(vsListView2.Count - 1, 3, "", 0)
Call .SubItemSet(vsListView2.Count - 1, 4, "", 0)
Call .SubItemSet(vsListView2.Count - 1, 5, "", 0)
End With
Next i
ElseIf MatureSum < vsListView2.Count Then
For i = MatureSum - 1 To vsListView2.Count - 1
vsListView2.ItemRemove i
Next i
End If
If MatureSum > 0 Then
For i = 0 To MatureSum
With vsListView2
Call .SubItemSet(i, 0, i, 0)
Call .SubItemSet(i, 1, i + 1, 0)
Call .SubItemSet(i, 2, Mature(i).name, 0)
Call .SubItemSet(i, 3, Mature(i).Location, 0)
Call .SubItemSet(i, 4, zhonglei(Mature(i).kind, 0), 0)
Call .SubItemSet(i, 5, time_mature(Mature(i).q), 0)
End With
DoEvents
Next i
End If
End If
End Sub
Private Sub vsListView2_ItemClick(Item As Integer) '按方向键
On Error Resume Next
If Item >= 0 Then
dianji2 = Item
End If
End Sub
Private Sub vsListView2_MouseUp(Button As Integer, Shift As Integer, X As Single, y As Single)
On Error Resume Next
If vsListView2.ItemHitTest(X, y) >= 0 Then
dianji2 = Val(vsListView2.ItemHitTest(X, y))
End If
End Sub
Private Sub vsListView2_DblClick() '双击偷取
On Error Resume Next
If Mature(dianji2).uID = Myuid Then
If Farmqk = True Then
Call SendHttp(1, Myuid, Mature(dianji2).Location - 1, Mature(dianji2).name, "0", 0)
Else
Call SendHttp(1, Myuid, Mature(dianji2).Location - 1, Mature(dianji2).name, "0", 1)
End If
Else
Call SendHttp(2, Mature(dianji2).uID, Mature(dianji2).Location - 1, Mature(dianji2).name, "0", Mature(dianji2).zl)
End If
End Sub
Private Sub WebBrowser1_DownloadBegin() '防止弹出非法错误的提示
On Error Resume Next
WebBrowser1.Silent = True
End Sub
Private Sub WebBrowser1_DownloadComplete()
On Error Resume Next
WebBrowser1.Silent = True
SetProcessWorkingSetSize GetCurrentProcess(), -1&, -1&
If InStr(webtem, "anniu=|") = 0 Then
webtem = Trim(WebBrowser1.Document.body.innertext)
Else
Call AnNiuxy '按钮广告响应
End If
End Sub
Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
On Error Resume Next
If tssj = True Then Exit Sub
If InStr(webtem, "anniu=|") = 0 Then
webtem = Trim(WebBrowser1.Document.body.innertext)
Else
Call AnNiuxy '按钮广告响应
End If
End Sub
Private Sub AnNiuAD_Click() '按钮广告位
On Error Resume Next
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
objIE.Navigate (AnNiuUrl)
End Sub
Private Sub Timer23_Timer()
On Error Resume Next
If DateDiff("s", adtime, Now) <= 300 Then
If InStr(webtem, "anniu=|") = 0 Then
webtem = Trim(WebBrowser1.Document.body.innertext)
Else
Call AnNiuxy '按钮广告响应
End If
Else
Timer23.Enabled = False
End If
End Sub
Sub AnNiuxy() '按钮广告响应
On Error Resume Next
If AnNiuAD.Visible = False And InStr(webtem, "anniu=|") > 0 Then
Dim tem As String, tem1 As String
tem = Split(webtem, "anniu=|")(1)
AnNiuAD.Caption = Split(tem, "|")(0)
tem1 = Split(webtem, "anniu_url=|")(1)
AnNiuUrl = Split(tem1, "|")(0)
AnNiuAD.Visible = True
Timer23.Enabled = False
End If
End Sub
Private Sub xyyzm() '弹出验证码
On Error Resume Next
Dim ts As Boolean
If yzm.Visible = False Then
If scyzmsj = 0 Or Time_C - scyzmsj >= 10 Then
Call jilu("系统", MyQQ, "QQ农场提示您：为了预防过度疲劳，请休息片刻，输入验证码才能继续操作!")
yzm.Frame1.Caption = "时间:" & Now
ts = True
Else
yzm.Frame1.Caption = "提示：输入错误,请重新输入!"
End If
If scyzmsj > 0 And Time_C - scyzmsj <= 10 Then
yzmcsi = yzmcsi + 1
If yzmcsi > 10 Then
scyzmsj = Time_C
yzmcsi = 0
XPButton21.Caption = "开始工作"
XPButton21.ForeColor = &HFF&
Call jilu("系统", MyQQ, "验证码已连续10次失败,现在已自动停止工作!")
Exit Sub
End If
Else
scyzmsj = Time_C
yzmcsi = 0
End If
Call qhico(True) '切换图标
yzm.Timer1.Enabled = True
yzm.Caption = "请输入验证码(QQ:" & MyQQ & ")"
If Form1.Visible = True Or yzmts = 0 Or yzmts = 1 Then
yzm.Show
FormTop yzm.hwnd, True
End If
If (yzmts = 0 Or yzmts = 2) And ts = True Then
If Dir(App.Path & "sound" & shengyin) <> "" Then
PlaySound App.Path & "sound" & shengyin, 0, SND_ASYNC Or SND_FILENAME
End If
End If
End If
End Sub
Private Sub Timer22_Timer() '响应验证码
Timer22.Enabled = False
If yzmlx.lx = -1 Then
sxdl = yzmlx.uID
Call update_From(yzmlx.rzl)
ElseIf yzmlx.lx = 1 Then
sxdl = listfarmid
Call update_From(listfarmzl)
Call addsxlb(Myuid, yzmlx.rzl) '加入刷新列表
ElseIf yzmlx.lx = 5 Then
sxlblx = 1
zxjiazai = False
Timer1.Enabled = False
Timer1.Interval = 100
Timer1.Enabled = True
ElseIf yzmlx.lx = 6 Then
sxlblx = 2
sdsx = True
zxjiazai = False
Timer1.Enabled = False
Timer1.Interval = 100
Timer1.Enabled = True
Else
Call SendHttp(yzmlx.lx, yzmlx.uID, yzmlx.id, yzmlx.name, yzmlx.bj, yzmlx.rzl)
End If
End Sub
Private Sub tongji(lx As Integer, id As Integer, sum, exp) '收益统计
If lx = 1 Then '收获
Label36.Caption = Val(Label36.Caption) + Val(sum) '果实数量
Label38.Caption = Val(Label38.Caption) + Val(sum) * Val(zhonglei(id, 2)) '价值
Label40.Caption = Val(Label40.Caption) + Val(exp) '经验
ElseIf lx = 2 Then '偷取
Label36.Caption = Val(Label36.Caption) + Val(sum) '果实数量
Label38.Caption = Val(Label38.Caption) + Val(sum) * Val(zhonglei(id, 2)) '价值
ElseIf lx = 3 Then '帮忙
Label38.Caption = Val(Label38.Caption) + Val(sum) '价值
Label40.Caption = Val(Label40.Caption) + Val(exp) '经验
Label45.Caption = Val(Label45.Caption) + 1
WritePrivateProfileString MyQQ, "BmCs", Label45.Caption, App.Path & "Config.ini"
ElseIf lx = 4 Then '狗咬
Label38.Caption = Val(Label38.Caption) - Val(sum) '价值
Else '其他加经验
Label40.Caption = Val(Label40.Caption) + Val(exp) '经验
End If
End Sub
Private Sub Label43_Click()
If MsgBox("您确定要清空所有数据，重新统计吗？", 64 Or vbYesNo, "清空确认") = vbYes Then
Label36.Caption = 0
Label38.Caption = 0
Label40.Caption = 0
End If
End Sub
Public Function qhico(yzm As Boolean) '切换图标
On Error Resume Next
TrayBalloon1 Form1, "当前版本：" & bbid & " " & bbname & " " & bbrq & "" & vbCrLf & "-----------------------------" & vbCrLf & "使用交流：http://www.h876.com", "QQ伴侣", NIIF_INFO, yzm
End Function