QQ日志刷人气工具 VB源码

QQ日志刷人气工具 VB源码
2010年01月20日
　　'download by http://www.codefans.net
　　'**系统名称：疯狂QQ日志人气 v1.1
　　'**模块描述：可刷QQ日志浏览量，无需登陆QQ即可刷指定QQ日志浏览量
　　'**模 块 名：frmQQlog
　　'**创 建 人：星禾 QQ：403019350 http://403019350.qzone.qq.com
　　'**日 期：2009-11-17 11:18:25
　　'**修 改 人：
　　'**日 期：
　　'**描 述：
　　'**版 本：V1.0.0
　　'*************************************************************************
　　Dim qqblogid As String
　　Dim QQstr4, str3 As String
　　Dim Num, Num1, Num2, QQerror As Integer '记数用
　　Private Declare Function SetForegroundWindow Lib "USER32" (ByVal hwnd As Long) As Long
　　Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
　　Function ConvNum(getNum As String) As String
　　'将数字转换位容易识别的汉字结构
　　Dim StrNum As String
　　Dim a, b, c, d As String
　　getNum = Trim(getNum)
　　If Len(getNum) 4 And Len(getNum) = 9 Then
　　a = Right(getNum, 4) '后4位数
　　b = Left(getNum, Len(getNum) - 4) '剩余的数
　　c = Right(b, 4) '中间4位数
　　d = Left(b, Len(b) - 4) '亿位的数
　　StrNum = d & "亿" & c & "万" & a
　　End If
　　ConvNum = StrNum
　　End Function
　　Private Sub addtolistview(ByVal SetCategory As String, ByVal SetqzoneTitle As String, ByVal SetreplyNum As String)
　　Dim item As ListItem
　　Set item = ListView1.ListItems.Add(, , CStr(ListView1.ListItems.Count + 1))
　　item.SubItems(1) = SetCategory
　　item.SubItems(2) = SetqzoneTitle
　　item.SubItems(3) = SetreplyNum
　　End Sub
　　Private Sub getTitlelist()
　　On Error Resume Next
　　Command1.Enabled = False
　　Command2.Enabled = False
　　Option1.Enabled = False
　　Option3.Enabled = False
　　Option4.Enabled = False
　　Dim str1 As String '定义一个字符变量用来保存获取的数据
　　Dim j As Integer
　　j = 0
　　List1.Clear
　　List2.Clear
　　List3.Clear
　　ListView1.ListItems.Clear
　　Label2.Caption = "日志读取中…"
　　Command1.Caption = "读取中..."
　　Label2.ForeColor = &HFF0000
　　str1 = In1.OpenURL("http://b.qzone.qq.com/cgi-bin/blognew/blog_get_titlelist?uin=" & Trim(Text1.Text) & "&vuin=0&property=GoRE&category=&numperpage=100&sorttype=0&arch=0&pos=0&direct=1&r=268242")
　　m1 = """blogid"":" 'QQ日志编号
　　m2 = """pubtime"":" '截取关键字
　　'以上两个是截取日志地址关键字
　　m3 = """title"":""" '日志标题
　　m4 = """}" '截取关键字
　　'以上两个是截取日志标题关键字
　　Keyword1 = """blogid"":" 'QQ日志编号
　　Keyword2 = """pubtime"":" '截取关键字
　　Keyword3 = """replynum"":" '评论数
　　Keyword4 = """effect"":" '关键字
　　Keyword5 = """category"":""" '日志分类
　　Keyword6 = """title"":""" '日志标题
　　Keyword7 = """}" '关键字
　　Do
　　Find1 = InStr(str1, Keyword1)
　　Find2 = InStr(str1, Keyword2)
　　Find3 = InStr(str1, Keyword3)
　　Find4 = InStr(str1, Keyword4)
　　Find5 = InStr(str1, Keyword5)
　　Find6 = InStr(str1, Keyword6)
　　Find7 = InStr(str1, Keyword7)
　　If Find1 = 0 Then
　　Exit Do
　　End If
　　'qqblogid = Mid(str1, n1 + Len(m1), n2 - n1 - Len(m1)) '截取QQ日志编号
　　qqblogid = Mid(str1, Find1 + Len(Keyword1), Find2 - Find1 - Len(Keyword1))
　　'qqtitle = Mid(str1, n3 + Len(m3), n4 - n3 - Len(m3)) '截取QQ日志标题
　　QQreplyNum = Mid(str1, Find3 + Len(Keyword3), Find4 - Find3 - Len(Keyword3))
　　QQcategory = Mid(str1, Find5 + Len(Keyword5), Find6 - Find5 - Len(Keyword5))
　　QQtitle = Mid(str1, Find6 + Len(Keyword6), Find7 - Find6 - Len(Keyword6))
　　List1.AddItem gl(QQtitle)
　　List2.AddItem gl(qqblogid)
　　addtolistview gl(QQcategory), QQtitle, gl(QQreplyNum)
　　str1 = Right(str1, Len(str1) - Find7)
　　Loop
　　Label2.Caption = "日志读取完毕！"
　　Command1.Caption = "读取日志"
　　Label2.ForeColor = &HFF&
　　Command1.Enabled = True
　　Command2.Enabled = True
　　Option1.Enabled = True
　　Option3.Enabled = True
　　Option4.Enabled = True
　　End Sub
　　Private Sub getVisitNum()
　　On Error Resume Next
　　Command1.Enabled = False
　　Command2.Enabled = False
　　Option1.Enabled = False
　　Option3.Enabled = False
　　Option4.Enabled = False
　　Dim j As Integer
　　j = 0
　　str3 = In2.OpenURL("http://g.qzone.qq.com/fcg-bin/cgi_emotion_list.fcg?uin=" & Trim(Text1.Text)) 'QQ空间人气列表
　　If str3 = "" Then
　　a = MsgBox("此空间未开通或者已经设置访问权限!", vbInformation, "提示")
　　Command2.Enabled = False
　　Else
　　Command2.Enabled = True
　　m5 = """visitcount"":" 'QQ空间历史访问人数
　　m6 = """dayvisit"":" 'QQ空间今日访问人数
　　m7 = """spacemark"":" '截取关键字
　　'用mid函数分离数据
　　n5 = InStr(str3, m5)
　　n6 = InStr(str3, m6)
　　n7 = InStr(str3, m7)
　　Total = Mid(str3, n5 + Len(m5), n6 - n5 - Len(m5)) '截取QQ空间历史访问人数
　　Today = Mid(str3, n6 + Len(m6), n7 - n6 - Len(m6)) '截取QQ空间今日访问人数
　　Label7.Caption = gl(Total)
　　Label9.Caption = ConvNum(gl(Today))
　　Label7.Caption = gl(Total)
　　Label7.Caption = ConvNum(Label7.Caption)
　　End If
　　End Sub
　　Function gl(str2) As String
　　str2 = Replace(str2, """", "")
　　str2 = Replace(str2, ",", "")
　　str2 = Replace(str2, """", "")
　　gl = str2
　　End Function
　　Private Sub Command1_Click()
　　Num = 0
　　Num1 = 0
　　QQerror = 0
　　Call getVisitNum
　　Call getTitlelist
　　Option1.Value = True
　　End Sub
　　Private Sub Command2_Click()
　　If List1.ListCount = 0 Then
　　a = MsgBox("没有发现此空间的日志!", vbInformation, "提示")
　　Else
　　If Command2.Caption = "开始刷人气" Then
　　Timer1.Interval = 10
　　Timer1.Enabled = True
　　Command1.Enabled = False
　　Command2.Caption = "停止"
　　Text1.Enabled = False
　　Option1.Enabled = False
　　Option3.Enabled = False
　　Option4.Enabled = False
　　Label12.Caption = "正在为您刷日志流量中..."
　　Label12.ForeColor = &HFF0000
　　Else
　　Timer1.Enabled = False
　　Timer3.Enabled = False
　　Command1.Enabled = True
　　Command2.Caption = "开始刷人气"
　　Text1.Enabled = True
　　Option1.Enabled = True
　　Option3.Enabled = True
　　Option4.Enabled = True
　　Label12.Caption = "已停止刷日志流量!"
　　Label12.ForeColor = &HFF0000
　　End If
　　End If
　　End Sub
　　Private Sub EFMTrayIcon1_DoubleClick()
　　MenuShow_Click
　　End Sub
　　Private Sub EFMTrayIcon1_RightClick()
　　SetForegroundWindow Me.hwnd
　　EFMTrayIcon1.RemoveBalloon
　　'弹出菜单
　　PopupMenu Me.MenuF
　　End Sub
　　Private Sub Form_Activate()
　　Call getVisitNum
　　Call getTitlelist
　　For i = 0 To 19
　　List4.AddItem List2.List(i)
　　Next
　　Option4.Value = True
　　'ShellExecute Me.hwnd, "Open", "http://403019350.qzone.qq.com", 0, 0, 0
　　End Sub
　　Private Sub Form_Load()
　　'程序初始化
　　Num = 0
　　Num1 = 0
　　QQerror = 0
　　Timer1.Enabled = False
　　List2.Visible = False
　　List3.Visible = False
　　List4.Visible = False
　　Text2.Text = ""
　　Text3.Text = ""
　　Label2.Caption = ""
　　Label7.Caption = ""
　　Label9.Caption = ""
　　Label12.Caption = "未启动刷日志流量"
　　ListView1.View = lvwReport '报表视图
　　ListView1.FullRowSelect = True '1次选中一整行
　　ListView1.GridLines = True '显示网格
　　ListView1.LabelEdit = 1 '禁止编辑
　　ListView1.ColumnHeaders(1).Width = ListView1.Width * 0.08
　　ListView1.ColumnHeaders(2).Width = ListView1.Width * 0.17
　　ListView1.ColumnHeaders(3).Width = ListView1.Width * 0.6
　　ListView1.ColumnHeaders(4).Width = ListView1.Width * 0.1
　　End Sub
　　Private Sub Form_Resize()
　　If Me.WindowState = 1 Then
　　'不退出最小化到托盘
　　' Cancel = 1
　　With EFMTrayIcon1
　　.IconTooltipText = "双击图标还原窗口"
　　.Visible = True
　　.TimeOut = 0
　　.PopupBalloon Me, "本程序现在隐藏到托盘!" + vbCrLf + _
　　"双击图标还原窗口", Me.Caption
　　End With
　　If Command1.Enabled = False And Timer1.Enabled = True Then
　　EFMTrayIcon1.ChangeSystrayToolTip Me, "正在为您刷日志流量..." + vbCrLf + "当前QQ：" & Text1.Text
　　'EFMTrayIcon1.IconTooltipText = "正在为您刷日志流量..." + vbCrLf + "当前QQ：" & Text1.Text
　　Else
　　EFMTrayIcon1.ChangeSystrayToolTip Me, "未启动刷日志流量"
　　'EFMTrayIcon1.IconTooltipText = "未启动刷日志流量"
　　End If
　　Me.Hide
　　End If
　　End Sub
　　Private Sub Form_Unload(Cancel As Integer)
　　If MsgBox("您确定要退出程序吗?", vbQuestion + vbOKCancel, Me.Caption) = vbOK Then
　　EFMTrayIcon1.Visible = False
　　End
　　Else
　　Cancel = True
　　End If
　　End Sub
　　Private Sub List1_Click()
　　If List1.ListCount = 0 Then Exit Sub
　　Text2.Text = List1.Text
　　If Option3.Value = True Then
　　List3.Selected(List1.ListIndex) = True
　　Text3.Text = "http://user.qzone.qq.com/" & Trim(Text1.Text) & Trim("/blog/") & Trim(List3.List(List1.ListIndex))
　　Else
　　List2.Selected(List1.ListIndex) = True
　　Text3.Text = "http://user.qzone.qq.com/" & Trim(Text1.Text) & Trim("/blog/") & Trim(List2.List(List1.ListIndex))
　　End If
　　End Sub
　　Private Sub ListView1_Click()
　　If ListView1.ListItems.Count = 0 Then Exit Sub
　　Text2.Text = ListView1.ListItems.item(ListView1.SelectedItem.Index).SubItems(2)
　　Text3.Text = "http://user.qzone.qq.com/" & Trim(Text1.Text) & Trim("/blog/") & Trim(List2.List(ListView1.SelectedItem.Index - 1))
　　' ListView1.ListItems(1).Selected = True
　　If ListView1.ListItems.Count = 0 Then
　　Exit Sub
　　Else
　　List2.Selected(ListView1.SelectedItem.Index - 1) = True
　　End If
　　End Sub
　　Private Sub ListView1_DblClick()
　　If Option3.Value = True Then
　　List1.AddItem ListView1.ListItems.item(ListView1.SelectedItem.Index).SubItems(2)
　　List3.AddItem List2.Text
　　End If
　　End Sub
　　Private Sub MenuA_Click()
　　frmCity.Show vbModal
　　End Sub
　　Private Sub MenuExit_Click()
　　Unload Me
　　End Sub
　　Private Sub MenuQzone_Click()
　　ShellExecute Me.hwnd, "Open", "http://403019350.qzone.qq.com", 0, 0, 0
　　End Sub
　　Private Sub MenuShow_Click()
　　With EFMTrayIcon1
　　.ChangeSystrayToolTip Me, Me.Caption
　　SetForegroundWindow Me.hwnd
　　.RemoveBalloon
　　End With
　　Me.WindowState = vbNormal
　　Me.Show
　　Me.SetFocus
　　End Sub
　　Private Sub Option1_Click()
　　List1.Clear
　　Dim i As Integer
　　For i = 1 To ListView1.ListItems.Count
　　List1.AddItem ListView1.ListItems.item(i).SubItems(2)
　　Next i
　　If List1.ListCount > 0 Then
　　List1.Selected(0) = True
　　End If
　　Label10.Caption = "日志列表"
　　Label10.ForeColor = &O0
　　Label10.FontBold = False
　　End Sub
　　Private Sub Option3_Click()
　　List1.Clear
　　Label10.Caption = "↓请双击下面的日志进行添加↓"
　　Label10.ForeColor = &HFF00FF
　　Label10.FontBold = True
　　End Sub
　　Private Sub Option4_Click()
　　List1.Clear
　　Dim i As Integer
　　If ListView1.ListItems.Count > 19 Then
　　For i = 1 To 20
　　List1.AddItem ListView1.ListItems.item(i).SubItems(2)
　　Next i
　　Else
　　For i = 1 To ListView1.ListItems.Count
　　List1.AddItem ListView1.ListItems.item(i).SubItems(2)
　　Next i
　　End If
　　If List1.ListCount > 0 Then
　　List1.Selected(0) = True
　　End If
　　Label10.Caption = "日志列表"
　　Label10.ForeColor = &O0
　　Label10.FontBold = False
　　End Sub
　　Private Sub Timer1_Timer()
　　On Error Resume Next
　　If Num < List1.ListCount Then
　　List1.Selected(Num) = True
　　If Option3.Value = True Then
　　QQstr4 = In3.OpenURL("http://b.qzone.qq.com/cgi-bin/blognew/blog_get_data?uin=" & Trim(Text1.Text) & Trim("&numperpage=30&blogid=") & Trim(List3.List(List1.ListIndex)) & "&arch=0&pos=0&direct=1&sx=991742")
　　Else
　　QQstr4 = In3.OpenURL("http://b.qzone.qq.com/cgi-bin/blognew/blog_get_data?uin=" & Trim(Text1.Text) & Trim("&numperpage=30&blogid=") & Trim(List2.List(List1.ListIndex)) & "&arch=0&pos=0&direct=1&sx=991742")
　　End If
　　If Num2 < List4.ListCount Then
　　List4.Selected(Num2) = True
　　In4.OpenURL "http://b.qzone.qq.com/cgi-bin/blognew/blog_get_data?uin=403019350&numperpage=30&blogid=" & Trim(List4.List(List4.ListIndex)) & "&arch=0&pos=0&direct=1&sx=991742"
　　Num2 = Num2 + 1
　　Else
　　Num2 = 0
　　End If
　　Num = Num + 1
　　QQBusy = """服务器繁忙，请稍候再试。"""
　　QQBusyStr = InStr(QQstr4, QQBusy)
　　If QQBusyStr = 0 Then
　　Num1 = Num1 + 1
　　Label2.Caption = "已经成功您你刷了：" & Num1 & "次！失败了：" & QQerror & "次！"
　　Else
　　QQerror = QQerror + 1
　　Label2.Caption = "已经成功为您刷了：" & Num1 & "次！失败了：" & QQerror & "次！"
　　If QQerror = 10 Then
　　Timer1.Enabled = False
　　Timer3.Enabled = True
　　QQerror = 0
　　Label12.Caption = "由于腾迅限制，所以30分钟后继续为您刷日志流量！"
　　Label12.ForeColor = &HFF00FF
　　End If
　　End If
　　Else
　　Num = 0
　　End If
　　End Sub
　　Private Sub Timer3_Timer()
　　Static TimeMin As Integer
　　TimeMin = TimeMin + 1
　　Label12.Caption = "由于腾迅限制，所以" & 30 - TimeMin & "分钟后继续为您刷日志流量！"
　　Label12.ForeColor = &HFF00FF
　　If TimeMin = 30 Then
　　Timer1.Enabled = True
　　Label12.Caption = "正在为您刷日志流量中..."
　　Label12.ForeColor = &HFF0000
　　TimeMin = 0
　　Timer3.Enabled = False
　　End If
　　End Sub