vb6_tieba_signin
/
BaiduProcess.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "BaiduProcess"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'//////////////////////////////////////////////////////////////////////////////
'@@summary
'@@require
'@@reference
'@@license
'@@author
'@@create
'@@modify
'//////////////////////////////////////////////////////////////////////////////


'//////////////////////////////////////////////////////////////////////////////
'//
'//      公有声明
'//
'//////////////////////////////////////////////////////////////////////////////


'------------------------------------------------------------------------------
'       接口继承
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       公有常量
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       公有数据类型
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       公有变量
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       公有API
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       事件声明
'------------------------------------------------------------------------------


'//////////////////////////////////////////////////////////////////////////////
'//
'//      私有声明
'//
'//////////////////////////////////////////////////////////////////////////////


'------------------------------------------------------------------------------
'       私有常量
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       私有数据类型
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       私有变量
'------------------------------------------------------------------------------
  Private responseBody As String
  Private responseHeaders As String
  Private baiduId As String
  Private token As String
  Private UBI As String
  Private codestring As String
  Private yanzhengma As String

  Private HISTORY As String
  Private BDUSS As String
  Private PTOKEN As String
  Private STOKEN As String
  Private SAVEUSERID As String
  Private USERNAMETYPE As String
  Private PASSID As String

  Private IS_NEW_USER As String
  Private BAIDU_WISE_UID As String
  Private TIEBAUID As String

  Private tbs As String
  Private WinHttp As WinHttp.WinHttpRequest
  '贴吧列表
  Private tieba() As String
'------------------------------------------------------------------------------
'       属性变量
'------------------------------------------------------------------------------


'------------------------------------------------------------------------------
'       私有API
'------------------------------------------------------------------------------


'//////////////////////////////////////////////////////////////////////////////
'//
'//      类
'//
'//////////////////////////////////////////////////////////////////////////////


'------------------------------------------------------------------------------
'       初始化
'------------------------------------------------------------------------------
Private Sub Class_Initialize()
    '
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
End Sub


'------------------------------------------------------------------------------
'       销毁
'------------------------------------------------------------------------------
Private Sub Class_Terminate()
  '
  Set WinHttp = Nothing
  Dim j() As String
End Sub


'//////////////////////////////////////////////////////////////////////////////
'//
'//      事件处理
'//
'//////////////////////////////////////////////////////////////////////////////


'//////////////////////////////////////////////////////////////////////////////
'//
'//      私有属性
'//
'//////////////////////////////////////////////////////////////////////////////


'//////////////////////////////////////////////////////////////////////////////
'//
'//      私有方法
'//
'//////////////////////////////////////////////////////////////////////////////
Private Function BytesToBstr(strBody, CodeBase) '编码转换("UTF-8"或者"GB2312"或者"GBK")
  Dim ObjStream
  Set ObjStream = CreateObject("Adodb.Stream")
  With ObjStream
    .Type = 1
    .Mode = 3
    .Open
    .Write strBody
    .Position = 0
    .Type = 2
    .Charset = CodeBase
    BytesToBstr = .ReadText
    .Close
  End With
  Set ObjStream = Nothing
End Function

Public Function 时间戳(ByVal 默认长度 As Boolean) As String
  Dim ShiJianChuocode As String
  Dim obj As Object
  Set obj = CreateObject("MSScriptControl.ScriptControl")
  obj.AllowUI = True
  obj.Language = "JavaScript"
  ShiJianChuocode = ShiJianChuocode & "function abc()" & vbCrLf
  ShiJianChuocode = ShiJianChuocode & "{" & vbCrLf
  ShiJianChuocode = ShiJianChuocode & "var timestamp = new Date().getTime();" & vbCrLf
  ShiJianChuocode = ShiJianChuocode & "return timestamp;" & vbCrLf
  ShiJianChuocode = ShiJianChuocode & "}" & vbCrLf
  ShiJianChuocode = ShiJianChuocode & "abc()" & vbCrLf
  时间戳 = obj.Eval(ShiJianChuocode)
  If 默认长度 = True Then
      时间戳 = Left(时间戳, Len(时间戳) - 3)
  End If
End Function
'//////////////////////////////////////////////////////////////////////////////
'//
'//      继承实现
'//
'//////////////////////////////////////////////////////////////////////////////


'//////////////////////////////////////////////////////////////////////////////
'//
'//      公有属性
'//
'//////////////////////////////////////////////////////////////////////////////


'//////////////////////////////////////////////////////////////////////////////
'//
'//      公有方法
'//
'//////////////////////////////////////////////////////////////////////////////
Public Sub Login(ByVal username As String, ByVal password As String, ByRef pictureBox As pictureBox)
  Dim WinHttp As WinHttp.WinHttpRequest '声明一个对象
  Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
  WinHttp.Open "GET", "http://www.baidu.com/cache/user/html/login-1.2.html", True
  WinHttp.SetTimeouts 30000, 30000, 30000, 30000
  WinHttp.SetRequestHeader "Host", "www.baidu.com"
  WinHttp.SetRequestHeader "Connection", "keep-alive"
  WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
  WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.130 Safari/537.36"
  WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
  WinHttp.Send            '发送
  WinHttp.WaitForResponse '异步发送
  responseBody = BytesToBstr(WinHttp.responseBody, "UTF-8")
  responseHeaders = WinHttp.GetAllResponseHeaders
  '获取百度ID
  baiduId = Split(Split(responseHeaders, "BAIDUID=")(1), ";")(0)

  WinHttp.Open "GET", "https://passport.baidu.com/v2/api/?getapi&class=login&tpl=mn&tangram=true", True
  WinHttp.SetTimeouts 30000, 30000, 30000, 30000
  WinHttp.SetRequestHeader "Host", "passport.baidu.com"
  WinHttp.SetRequestHeader "Connection", "keep-alive"
  WinHttp.SetRequestHeader "Accept", "*/*"
  WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.130 Safari/537.36"
  WinHttp.SetRequestHeader "Referer", "http://www.baidu.com/cache/user/html/login-1.2.html"
  WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
  WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId
  WinHttp.Send            '发送
  WinHttp.WaitForResponse '异步发送
  responseBody = BytesToBstr(WinHttp.responseBody, "UTF-8")
  responseHeaders = WinHttp.GetAllResponseHeaders
  token = Split(Split(responseBody, "login_token='")(1), "'")(0)

  WinHttp.Open "GET", "https://passport.baidu.com/v2/api/?logincheck&callback=bdPass.api.login._needCodestringCheckCallback&tpl=mn&charset=UTF-8&index=0&username=" & username & "&isphone=false&time=" & 时间戳(False), True
  WinHttp.SetTimeouts 30000, 30000, 30000, 30000
  WinHttp.SetRequestHeader "Host", "passport.baidu.com"
  WinHttp.SetRequestHeader "Connection", "keep-alive"
  WinHttp.SetRequestHeader "Accept", "*/*"
  WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.130 Safari/537.36"
  WinHttp.SetRequestHeader "Referer", "http://www.baidu.com/cache/user/html/login-1.2.html"
  WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
  WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId & ":FG=1; HOSUPPORT=1"
  WinHttp.Send            '发送
  WinHttp.WaitForResponse '异步发送
  responseBody = BytesToBstr(WinHttp.responseBody, "UTF-8")
  responseHeaders = WinHttp.GetAllResponseHeaders
  UBI = Split(Split(responseHeaders, "UBI=")(1), ";")(0)

  If InStr(responseBody, "jxIcaptchaservice") > 0 Then '如果需要验证码
      codestring = Split(Split(responseBody, "codestring" & Chr(34) & ":" & Chr(34))(1), Chr(34))(0)
      WinHttp.SetTimeouts 30000, 30000, 30000, 30000
      WinHttp.Open "GET", "https://passport.baidu.com/cgi-bin/genimage?" & codestring & "&v=" & 时间戳(False), True
      WinHttp.SetRequestHeader "Host", "passport.baidu.com"
      WinHttp.SetRequestHeader "Connection", "keep-alive"
      WinHttp.SetRequestHeader "Accept", "image/webp,*/*;q=0.8"
      WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.130 Safari/537.36"
      WinHttp.SetRequestHeader "Referer", "http://www.baidu.com/cache/user/html/login-1.2.html"
      WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
      WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId & "; HOSUPPORT=1; UBI=" & UBI
      WinHttp.Send
      WinHttp.WaitForResponse
      Dim VarifyCodeBitmapBytes() As Byte
      VarifyCodeBitmapBytes = WinHttp.responseBody
      Open App.Path & "\验证码.jpg" For Binary As #1
      Put #1, , VarifyCodeBitmapBytes
      Close #1
      pictureBox.Picture = LoadPicture(App.Path & "\验证码.jpg")
      yanzhengma = InputBox("", "请输入验证码", "")
  End If

  Dim ShuJu As String
  ShuJu = "ppui_logintime=10737&charset=utf-8&codestring=" & codestring & "&token=" & token & "&isPhone=false&index=0&u=&safeflg=0&staticpage=http%3A%2F%2Fwww.baidu.com%2Fcache%2Fuser%2Fhtml%2Fjump.html&loginType=1&tpl=mn&callback=parent.bdPass.api.login._postCallback&username=" & username & "&password=" & password & "&verifycode=" & yanzhengma & "&mem_pass=on" '设置POST数据
  WinHttp.Open "POST", "https://passport.baidu.com/v2/api/?login", True
  WinHttp.SetTimeouts 30000, 30000, 30000, 30000
  WinHttp.SetRequestHeader "Host", "passport.baidu.com"
  WinHttp.SetRequestHeader "Connection", "keep-alive"
  WinHttp.SetRequestHeader "Content-Length", Len(ShuJu)
  WinHttp.SetRequestHeader "Cache-Control", "max-age=0"
  WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
  WinHttp.SetRequestHeader "Origin", "http://www.baidu.com"
  WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.130 Safari/537.36"
  WinHttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  WinHttp.SetRequestHeader "Referer", "http://www.baidu.com/cache/user/html/login-1.2.html"
  WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
  WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId & "; HOSUPPORT=1; UBI=" & UBI
  WinHttp.Send ShuJu       '发送
  WinHttp.WaitForResponse  '异步发送
  responseBody = BytesToBstr(WinHttp.responseBody, "UTF-8")
  responseHeaders = WinHttp.GetAllResponseHeaders
  If InStr(responseBody, "error=0") > 0 Then '如果登录成功
      HISTORY = Split(Split(responseHeaders, "HISTORY=")(1), ";")(0)
      BDUSS = Split(Split(responseHeaders, "BDUSS=")(1), ";")(0)
      PTOKEN = Split(Split(responseHeaders, "PTOKEN=")(2), ";")(0)
      STOKEN = Split(Split(responseHeaders, "STOKEN=")(1), ";")(0)
      SAVEUSERID = Split(Split(responseHeaders, "SAVEUSERID=")(1), ";")(0)
      USERNAMETYPE = Split(Split(responseHeaders, "USERNAMETYPE=")(1), ";")(0)
      UBI = Split(Split(responseHeaders, "UBI=")(1), ";")(0)
      PASSID = Split(Split(responseHeaders, "PASSID=")(1), ";")(0)
  Else '如果登录失败
      MsgBox "登录失败"
      Exit Sub
  End If
End Sub

Public Sub SetTieba(ByRef showList As ListBox)
  ReDim tieba(0)
  Dim isShow As Boolean
  If showList Is Nothing Then
    isShow = False
  Else
    isShow = True
    showList.Clear
  End If
  WinHttp.Open "GET", "http://tieba.baidu.com/?page=like", True
  WinHttp.SetTimeouts 30000, 30000, 30000, 30000
  WinHttp.SetRequestHeader "Host", "tieba.baidu.com"
  WinHttp.SetRequestHeader "Connection", "keep-alive"
  WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
  WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (iPhone; U; CPU iPhone OS 4_2_1 like Mac OS X; en-us) AppleWebKit/533.17.9 (KHTML, like Gecko) Version/5.0.2 Mobile/8C148 Safari/6533.18.5"
  WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
  WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId & "; BDUSS=" & BDUSS
  WinHttp.Send            '发送
  WinHttp.WaitForResponse '异步发送
  responseBody = BytesToBstr(WinHttp.responseBody, "utf-8")
  responseHeaders = WinHttp.GetAllResponseHeaders
  IS_NEW_USER = Split(Split(responseHeaders, "IS_NEW_USER=")(1), ";")(0)
  BAIDU_WISE_UID = Split(Split(responseHeaders, "BAIDU_WISE_UID=")(1), ";")(0)
  TIEBAUID = Split(Split(responseHeaders, "TIEBAUID=")(1), ";")(0)
  tbs = Split(Split(responseBody, "tbs" & Chr(34) & ":" & Chr(34))(1), Chr(34))(0)
  '-----------------------------------------------------------------打开手机版贴吧个人中心
  '-----------------------------------------------------------------
  If InStr(responseBody, "<div class=" & Chr(34) & "forumTile_name" & Chr(34) & ">") > 0 Then
      Dim a As Integer
      For a = 1 To UBound(Split(responseBody, "<div class=" & Chr(34) & "forumTile_name" & Chr(34) & ">"))
        ReDim Preserve tieba(a)
        tieba(a) = Split(Split(responseBody, "<div class=" & Chr(34) & "forumTile_name" & Chr(34) & ">")(a), "</div>")(0)
        If isShow Then
          showList.AddItem tieba(a)
          showList.ListIndex = showList.ListCount - 1
        End If
      Next a
  Else
      MsgBox "你这屌毛连个贴吧都没有，签个毛线的到啊？"
      Exit Sub
  End If
End Sub

Public Sub SignTieBa(ByRef showList As ListBox, ByRef sourceList As ListBox)
  Dim tiebaName As String
  Dim b As Integer
  For b = 1 To UBound(tieba)
    tiebaName = tieba(b)
    If Not sourceList Is Nothing Then
      sourceList.ListIndex = b - 1
    End If

    '-----------------------------------------------------------------
    WinHttp.Open "GET", "http://tieba.baidu.com/mo/q/sign?tbs=" & tbs & "&kw=" & tiebaName & "&is_like=1&fid=1177", True
    WinHttp.SetTimeouts 30000, 30000, 30000, 30000
    WinHttp.SetRequestHeader "Host", "tieba.baidu.com"
    WinHttp.SetRequestHeader "Connection", "keep-alive"
    WinHttp.SetRequestHeader "Accept", "application/json"
    WinHttp.SetRequestHeader "X-Requested-With", "XMLHttpRequest"
    WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (iPhone; U; CPU iPhone OS 4_2_1 like Mac OS X; en-us) AppleWebKit/533.17.9 (KHTML, like Gecko) Version/5.0.2 Mobile/8C148 Safari/6533.18.5"
    WinHttp.SetRequestHeader "Referer", "http://tieba.baidu.com/f?kw=" & tiebaName & "&pn=0&"
    WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
    WinHttp.SetRequestHeader "Cookie", "BAIDUID=" & baiduId & "; BDUSS=" & BDUSS & "; IS_NEW_USER=" & IS_NEW_USER & "; BAIDU_WISE_UID=" & BAIDU_WISE_UID & "; TIEBAUID=" & TIEBAUID & "; CLIENTWIDTH=320; CLIENTHEIGHT=480; SEENKW=vb; mo_originid=2; LASW=320; is_hide_sign_like_client_ad_dialog=true"
    WinHttp.Send            '发送
    WinHttp.WaitForResponse '异步发送
    responseBody = BytesToBstr(WinHttp.responseBody, "utf-8")
    responseHeaders = WinHttp.GetAllResponseHeaders
    If InStr(responseBody, "{" & Chr(34) & "no" & Chr(34) & ":0," & Chr(34) & "error") > 0 Then
      showList.AddItem Now & " " & tiebaName & " " & "签到成功！": showList.ListIndex = showList.ListCount - 1
    Else
      If InStr(responseBody, "\u4eb2\uff0c\u4f60\u4e4b\u524d\u5df2\u7ecf\u7b7e\u8fc7\u4e86") > 0 Then
        showList.AddItem Now & " " & tiebaName & " " & "签到失败！重复签到。": showList.ListIndex = showList.ListCount - 1
      Else
        showList.AddItem Now & " " & tiebaName & " " & "签到失败！原因未知。": showList.ListIndex = showList.ListCount - 1
      End If
    End If
    '-----------------------------------------------------------------签到
    DoEvents
  Next b
End Sub