用VB实现SmartQQ机器人

这里为了便于介绍程序设计的流程，更多以代码形式给出，具体可用火狐浏览器的firebug插件来抓包分析，或者用谷歌浏览器的开发者工具进行抓包。抓包地址是：http://w.qq.com

第一步，是二维码，登录上面的网址我们可以看到一个二维码页面，那么如果要实现机器人，首先第一步必须完成登录，通过手机端的扫码。具体代码获取二维码方式如下：

获取二维码的链接：https://ssl.ptlogin2.qq.com/ptqrshow?appid=501004106&e=0&l=M&s=5&d=72&v=4&t=0.0001，这里的0.0001最好用随机数来。这里用0.0001或者其他参数都可以。

得到后我们需要下载二维码。VB的实现方式比较简单。

用这个函数，这是我个人写的：

 Function DownNetFile(ByVal nUrl As String, ByVal nFile As String)
     Dim XmlHttp, b() As Byte
     Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
     XmlHttp.Open "GET", nUrl, False
     XmlHttp.Send
     If XmlHttp.readyState =  Then
         b() = XmlHttp.ResponseBody
         Open nFile For Binary As #
         Put #, , b()
         Close #
     End If

     Set XmlHttp = Nothing
 End Function

不妨让这个事件为getvcode。这个过程就是：

  DownNetFile "https://ssl.ptlogin2.qq.com/ptqrshow?appid=501004106&e=0&l=M&s=5&d=72&v=4&t=" & GetRandom, App.Path & "\QQvcode.png" '下载二维码
     Call PaintPng(App.Path & "\QQvcode.png", Picture1.hdc, , )

这里有个paintpng,这是一个模块，由于我们下载下来的二维码是png格式的，VB本身的图片控件是不支持png格式的，因此需要一个模块。

 Private Type GdiplusStartupInput
     GdiplusVersion As Long
     DebugEventCallback As Long
     SuppressBackgroundThread As Long
     SuppressExternalCodecs As Long
 End Type
 Private Enum GpStatus
     Ok =
     GenericError =
     InvalidParameter =
     OutOfMemory =
     ObjectBusy =
     InsufficientBuffer =
     NotImplemented =
     Win32Error =
     WrongState =
     Aborted =
     FileNotFound =
     ValueOverflow =
     AccessDenied =
     UnknownImageFormat =
     FontFamilyNotFound =
     FontStyleNotFound =
     NotTrueTypeFont =
     UnsupportedGdiplusVersion =
     GdiplusNotInitialized =
     PropertyNotFound =
     PropertyNotSupported =
 End Enum
 Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = ) As GpStatus
 Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
 Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single) As GpStatus
 Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
 Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
 Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
 Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal fileName As String, image As Long) As GpStatus
 Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
 Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
 Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus
 Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus

 Dim gdip_Token&, gdip_pngImage&, gdip_Graphics&, Picname$

 Public Sub PaintPng(ByVal sFileName As String, ByVal hdc As Long, ByVal mX As Long, ByVal mY As Long)
     '显示PNG图片到指定的DC环境
     '
     'mX与mY单位为象素.
     Dim lngHeight As Long, lngWidth As Long

     Call GDI_Initialize

     If GdipCreateFromHDC(hdc, gdip_Graphics) <> Ok Then
         GdiplusShutdown gdip_Token
     Else
         Call GdipLoadImageFromFile(StrConv(GetShortName(sFileName), vbUnicode), gdip_pngImage)
         Call GdipGetImageHeight(gdip_pngImage, lngHeight)   '
         Call GdipGetImageWidth(gdip_pngImage, lngWidth)
         Call GdipDrawImageRect(gdip_Graphics, gdip_pngImage, mX, mY, lngWidth, lngHeight)
     End If

     Call GDI_Terminate
 End Sub

 Private Sub GDI_Initialize()
     Dim GpInput As GdiplusStartupInput

     GpInput.GdiplusVersion =
     gdip_Graphics =
     gdip_pngImage =
     If GdiplusStartup(gdip_Token, GpInput) <> Ok Then
         Debug.Print "GDI初始失败！"
 '        MsgBox "GDI初始失败！"
     End If
 End Sub

 Private Sub GDI_Terminate()
     GdipDisposeImage gdip_pngImage
     GdipDeleteGraphics gdip_Graphics
     GdiplusShutdown gdip_Token
 End Sub

 Private Function GetShortName(ByVal sLongFileName As String) As String
     Dim lRetVal&, sShortPathName$
     sShortPathName = Space()
     Call GetShortPathName(sLongFileName, sShortPathName, )
     If InStr(sShortPathName, Chr()) >  Then
         GetShortName = Trim(Mid(sShortPathName, , InStr(sShortPathName, Chr()) - ))
     Else
         GetShortName = Trim(sShortPathName)
     End If
 End Function

二维码获取到了，那么就需要判断是否扫码了，需要访问一个链接：

 https://ssl.ptlogin2.qq.com//ptqrlogin?webqq_type=&remember_uin=&login2qq=&aid=&u1=http%3A%2F%2Fw.qq.com%2Fproxy.html%3Flogin2qq%3D1%26webqq_type%3D10&ptredirect=&ptlang=&daid=&from_ui=&pttype=&dumy=&fp=loginerroralert&action=--" & (GetRandom * 900000 + 1000000) & "&mibao_css=m_webqq&t=undefined&g=&js_type=&js_ver=&login_sig=&pt_randsalt=

在这个链接里会返回验证的状态，包括：正在验证，未失效，已失效。这里不再赘述。

如果认证成功，则会返回一个状态文本，里面包含QQ号，昵称，以及下一步我们将要访问的一个checkurl.

第二步：获取checkurl

VB如何提取这个checkurl呢？最简单的方法是字符串截取函数：

  On Error Resume Next
     Dim ptwebqqtemp As String
     Dim checkurltemp As String
     Dim checkurl As String
     ptwebqqtemp = FileStr(App.Path & "\Cookie.txt")
     checkurltemp = FileStr(App.Path & "\Data\Checkurl.txt")
     ptwebqq = Mid(ptwebqqtemp, InStr(, ptwebqqtemp, "ptwebqq=") + Len("ptwebqq="), )
     checkurl = Mid(checkurltemp, InStr(, checkurltemp, "http://"), InStr(InStr(, checkurltemp, "http://"), checkurltemp, "'") - InStr(, checkurltemp, "http://"))
     set_ini App.Path & "\Config\Config.ini", "QQ", "ptwebqq", ptwebqq
     set_ini App.Path & "\Config\Config.ini", "QQ", "checkurl", checkurl

这里我给保存到了一个配置文件中了，用于后面使用。

第三步：在这一步中，我们要拿到了vfwebqq和ptwebqq这2个参数了。

这一次我们需要拿到vfwebqq.

1 Dim URL As String
2     Dim s As String
3     Dim t As String
4
5     getHtmlstr get_ini(App.Path & "\Config\Config.ini", "QQ", "checkurl", 500)
6     ptwebqq = get_ini(App.Path & "\Config\Config.ini", "QQ", "ptwebqq", 255)
7     URL = "http://s.web2.qq.com/api/getvfwebqq?ptwebqq=" & ptwebqq & "&clientid=53999199&psessionid=&t=" & script("function a(){var timestamp=new Date().getTime();return timestamp;}a();")
8     Httpget URL, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", "vfwebqq"

这里有个时间戳，VB本身对这个处理能力是极差的，所以我们求助于js。

这里给出VB调用js的代码：

1 Public Function script(code As String) As String
2     Dim obj As Object
3     Set obj = CreateObject("MSScriptControl.ScriptControl")
4     obj.AllowUI = True
5     obj.Language = "JavaScript"
6     script = obj.Eval(code)
7 End Function

这个代码是执行js中代码的函数，写的很简单。

第四步：是最为关键的一步，因为在这里我们还有第二次登录。需要用到一个参数ptwebqq。需要用到的部分值在前一次访问返回的cookie中，VB对cookie的操作方法极少，我使用的是inet控件的一个方法.

获取psessionid.

  Dim url1 As String
     Dim Data As String
     Dim psessionidtemp As String
     psessionidtemp = FileStr(App.Path & "\Data\SecondLogin.txt")
     url1 = "http://d1.web2.qq.com/channel/login2"
     Data = "r=%7B%22ptwebqq%22%3A%22" & ptwebqq & "%22%2C%22clientid%22%3A53999199%2C%22psessionid%22%3A%22%22%2C%22status%22%3A%22online%22%7D"
     Httppost url1, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", Data, "Secondlogin"
     psessionid = Mid(psessionidtemp, InStr(, psessionidtemp, "psessionid"":""") + Len("psessionid"":"""), )

第五步：到这里我们已经完成了基本的登录了，包括第一次上线和正式登录。

在此之前我们需要一个函数，就是hash。VB自身没有这个函数，为此在写这个函数不值得，腾讯关于此算法也是经常换，因此我们直接从腾讯的SmartQQ官网的js文件中直接提取用我们前面提到的js函数来执行加密。

函数如下：

 Function Hash() As String                                                       'HASH
     Hash = "function hashU(x, K) {" & _
     "x += """";" & _
     "for (var N = [], T = 0; T < K.length; T++) N[T % 4] ^= K.charCodeAt(T);" & _
     " var U = [""EC"", ""OK""]," & _
     "V = [];" & _
     "V[0] = x >> 24 & 255 ^ U[0].charCodeAt(0);" & _
     "V[1] = x >> 16 & 255 ^ U[0].charCodeAt(1);" & _
     "V[2] = x >> 8 & 255 ^ U[1].charCodeAt(0);" & _
     " V[3] = x & 255 ^ U[1].charCodeAt(1);" & _
     " U = [];" & _
     "for (T = 0; T < 8; T++) U[T] = T % 2 == 0 ? N[T >> 1] : V[T >> 1];" & _
     "N = [""0"", ""1"", ""2"", ""3"", ""4"", ""5"", ""6"", ""7"", ""8"", ""9"", ""A"", ""B"", ""C"", ""D"", ""E"", ""F""];" & _
     "V = """";" & _
     "for (T = 0; T < U.length; T++) {" & _
     "V += N[U[T] >> 4 & 15];" & _
     " V += N[U[T] & 15]" & _
     "  } " & _
     " return V;" & _
     "};"
 End Function

这一次我们获取好友列表、个人信息、讨论组、群信息等：

获取好友列表：

     Dim URL As String
     Dim Data As String
     vfwebqq = Mid(FileStr(App.Path & "\Data\vfwebqq.txt"), InStr(, FileStr(App.Path & "\Data\vfwebqq.txt"), "vfwebqq"":""") + Len("vfwebqq"":"""), )
     URL = "http://s.web2.qq.com/api/get_user_friends2"
     Data = "r=%7B%22vfwebqq%22%3A%22" & vfwebqq & "%22%2C%22hash%22%3A%22" & script(Hash & vbCrLf & "hashU(""" & qq & """,""" & ptwebqq & """);") & "%22%7D"
     Httppost URL, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", Data, "GetFriendList"

获取个人信息：

     Dim URL As String
     URL = "http://s.web2.qq.com/api/get_self_info2?t=" & script("function a(){var timestamp=new Date().getTime();return timestamp;}a();")
     Httpget URL, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", "UserInformation" '获得个人信息
     face = getface(FileStr(App.Path & "\Data\UserInformation.txt"))
     qq = getqq(FileStr(App.Path & "\Data\UserInformation.txt"))

获取讨论组信息：

     Dim URL As String
     URL = "http://s.web2.qq.com/api/get_discus_list?clientid=53999199&psessionid=" & psessionid & "&vfwebqq=" & vfwebqq & "&t=" & script("function a(){var timestamp=new Date().getTime();return timestamp;}a();")
     Httpget URL, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", "DiscussList" '获得讨论组信息

获取群信息：

     Dim URL As String
     Dim Data As String
     Data = "r=%7B%22vfwebqq%22%3A%22" & vfwebqq & "%22%2C%22hash%22%3A%22" & script(Hash & vbCrLf & "hashU(""" & qq & """,""" & ptwebqq & """);") & "%22%7D"
     URL = "http://s.web2.qq.com/api/get_group_name_list_mask2"
     Httppost URL, "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", Data, "Grouplist"

获取最近联系人的相关信息：

     Dim URL As String
     URL = "http://d1.web2.qq.com/channel/get_recent_list2"
     Httpget URL, "http://d1.web2.qq.com/proxy.html?v=20151105001&callback=1&id=2", "RencentList" '获得讨论组信息

第六步：

我们已经获取了相关信息，最重要的一步就是接收消息：

 URL = "http://d1.web2.qq.com/channel/poll2"
     Data = "r=%7B%22ptwebqq%22%3A%22" & ptwebqq & "%22%2C%22clientid" & _
     "%22%3A53999199%2C%22psessionid%22%3A%22" & psessionid & "%22%2C%22key%22%3A%22%22%7D"
     Inet2.Execute URL, "post", Data, "Content-Type: application/x-www-form-urlencoded" & vbCrLf & "Referer:http://d1.web2.qq.com/proxy.html?v=20151105001&callback=1&id=2"
     Do While Inet2.StillExecuting
         DoEvents
     Loop
     binbuff() = Inet2.GetChunk(, icByteArray)
     m = Utf8ToUnicode(binbuff)

这里我使用的是一个inet2的控件，它用于接收消息的，所用到的参数在前面的步骤中我们已经获取到了，唯一需要注意的是返回的是utf-8格式的需要转换，我给出一个转换函数：

 Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
 Private Const CP_UTF8 =
 Function Utf8ToUnicode(ByRef Utf() As Byte) As String
     Dim lRet As Long
     Dim lLength As Long
     Dim lBufferSize As Long
     lLength = UBound(Utf) - LBound(Utf) +
     If lLength <=  Then Exit Function
     lBufferSize = lLength *
     Utf8ToUnicode = String$(lBufferSize, Chr())
     lRet = MultiByteToWideChar(CP_UTF8, , VarPtr(Utf()), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
     If lRet <>  Then
         Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
     Else
         Utf8ToUnicode = ""
     End If
 End Function

注意前面的全部返回数据包均为utf-8格式的，均需要此函数进行转换。

在返回消息时可能会遇到retcode为103之类的。这时需要登录网页版的smartqq，然后退出，再回来登录我们用VB写的程序就行了。个人认为可能是腾讯的一个保护机制。

第七步：在第六步中，我已经将接收消息的过程写好了，那么还有一个重要的事就是发送消息。这个很容易实现，然而很遗憾的是这个SmartQQ协议阉割的东西太多了。能发送的只有文字和部分标签，这里我就不对表情的代码进行解析了，都是(face,id)。

具体代码如下：

 If lb = "个人" Then
 URL = "https://d1.web2.qq.com/channel/send_buddy_msg2"
     Data = "r=%7B%22to%22%3A" & uin & "%2C%22content%22%3A%22%5B%5C%22" & UTF8_URLEncoding(fsxx) & "%5C%22%2C%5B%5C%22font%5C%22%2C%7B%5C%22name" & _
     "%5C%22%3A%5C%22%E5%AE%8B%E4%BD%93%5C%22%2C%5C%22size%5C%22%3A10%2C%5C%22style%5C%22%3A%5B0%2C0%2C0%5D" & _
     "%2C%5C%22color%5C%22%3A%5C%22000000%5C%22%7D%5D%5D%22%2C%22face%22%3A726%2C%22clientid%22%3A53999199" & _
     "%2C%22msg_id%22%3A" & id & "%2C%22psessionid%22%3A%22" & psessionid & "%22%7D"
     End If
 If lb = "讨论组" Then
     URL = "https://d1.web2.qq.com/channel/send_discu_msg2"
     Data = "r=%7B%22did%22%3A" & uin & "%2C%22content%22%3A%22%5B%5C%22" & UTF8_URLEncoding(fsxx) & "%5C%22%2C%5B%5C%22font%5C%22%2C%7B%5C%22name" & _
     "%5C%22%3A%5C%22%E5%AE%8B%E4%BD%93%5C%22%2C%5C%22size%5C%22%3A10%2C%5C%22style%5C%22%3A%5B0%2C0%2C0%5D" & _
     "%2C%5C%22color%5C%22%3A%5C%22000000%5C%22%7D%5D%5D%22%2C%22face%22%3A" & face & "%2C%22clientid%22%3A53999199" & _
     "%2C%22msg_id%22%3A" & id & "%2C%22psessionid%22%3A%22" & psessionid & "%22%7D"
 End If
 If lb = "群" Then
     URL = "https://d1.web2.qq.com/channel/send_qun_msg2"
     Data = "r=%7B%22group_uin%22%3A" & uin & "%2C%22content%22%3A%22%5B%5C%22" & UTF8_URLEncoding(fsxx) & "%5C%22%2C%5B%5C%22font%5C%22%2C%7B%5C%22name" & _
     "%5C%22%3A%5C%22%E5%AE%8B%E4%BD%93%5C%22%2C%5C%22size%5C%22%3A10%2C%5C%22style%5C%22%3A%5B0%2C0%2C0%5D" & _
     "%2C%5C%22color%5C%22%3A%5C%22000000%5C%22%7D%5D%5D%22%2C%22face%22%3A" & face & "%2C%22clientid%22%3A53999199" & _
     "%2C%22msg_id%22%3A" & id & "%2C%22psessionid%22%3A%22" & psessionid & "%22%7D"
 End If

发送消息使用的是“post”方法。fsxx为发送的消息。

这里我用if-endif实现的，其实这样写不够简洁，可以考虑用select-case来实现，lb是我在接收消息中定义的一个全局变量因为我们需要知道消息来自哪里，不仅仅是lb还有发送者的uin。这里的uin是一个临时使用的编号，每个人、群、讨论组都是只有一天有效期的。所以如果做QQ机器人，我们需要将uin转为QQ号。具体实现方法如下：

 Httpget "http://s.web2.qq.com/api/get_friend_uin2?tuin=" & uin & "&type=1&vfwebqq=" & vfwebqq & "&t=" & script("function a(){var timestamp=new Date().getTime();return timestamp;}a();"), "http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1", "GetRealQQ" '这是获取真实的qq或者群号

在返回的json数据包中解析即可。这里也给出json的解析方式。

以获取face值为例

 Function getface(jsoncode As String) As String '这是json的解析函数
     On Error GoTo a
     Dim ScriptObj As Object
     Set ScriptObj = CreateObject("MSScriptControl.ScriptControl")
     ScriptObj.AllowUI = True
     ScriptObj.Language = "JavaScript"
     ScriptObj.AddCode "var data = " & jsoncode & ";"
     getface = ScriptObj.Eval("data.result.face")
 a:
     Exit Function '如果出错了就退出函数
 End Function

其他的修改eval()即可。

到这里已经将SmartQQ的全部协议过程解析完。可以借助此协议设计相关的QQ机器人。