写了段VBA代码，帮你爬取TA在QQ空间的说说数据

Sub WebCrawlerQzone()

Dim strURL As String

Dim strCookie As String

Dim strText As String

Dim strGTK As String

Dim strKey As String

Dim strUserName As String

Dim strMsg As String

Dim intPageNum As Long

Dim lngCreateTime As Long

Dim k As Long

Dim i As Long

Dim blnClick As Boolean

Dim objIE As Object

Dim objWINHTTP As Object

Dim objDIC As Object

Dim objDOM As Object

Dim objTagA As Object

Dim objList As Object

Dim objWindow As Object

Dim vntTime As Variant

Dim vntQQNum As Variant

Set objDIC = CreateObject("scripting.dictionary")

Set objIE = CreateObject("InternetExplorer.Application")

Set objWINHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

Set objDOM = CreateObject("htmlfile")

Set objWindow = objDOM.parentWindow

strURL = "https://xui.ptlogin2.qq.com/cgi-bin/xlogin?"

strURL = strURL & "proxy_url=https%3A//qzs.qq.com/"

strURL = strURL & "qzone/v6/portal/proxy.html"

strURL = strURL & "&appid=549000912"

strURL = strURL & "&s_url=https%3A%2F%2Fqzs.qzone.qq.com" _

& "%2Fqzone%2Fv5%2Floginsucc.html%3Fpara%3Dizone"

With objIE

.navigate strURL

.Visible = False

vntTime = Timer

Do While Timer

Loop

Do Until .readyState = 4

DoEvents

Loop

For Each objTagA In .document.getElementsByTagName("a")

If objTagA.TabIndex = 2 Then

strUserName = objTagA.innerText

objTagA.Click

blnClick = True

Exit For

End If

Next

If Not blnClick Then

MsgBox strUserName & "您的QQ软件未登录或QQ空间未开通。"

Exit Sub

End If

vntTime = Timer

Do While Timer

Loop

strCookie = .document.cookie

.Quit

End With

strKey = Split(Split(strCookie, "p_skey=")(1), ";")(0)

strGTK = strGetGTK(strKey)

vntQQNum = [b1].Value

strURL = "https://user.qzone.qq.com/"

strURL = strURL & "proxy/domain/taotao.qq.com/"

strURL = strURL & "cgi-bin/emotion_cgi_msglist_v6?"

strURL = strURL & "num=20"

strURL = strURL & "&callback=_preloadCallback"

strURL = strURL & "&format=jsonp"

strURL = strURL & "&uin=" & vntQQNum

strURL = strURL & "&g_tk=" & strGTK

ActiveSheet.UsedRange.Offset(2).ClearContents

k = 3

On Error Resume Next

Application.ScreenUpdating = False

Do While 1 = 1

intPageNum = intPageNum + 20

With objWINHTTP

.Open "GET", strURL & "&pos=" & intPageNum - 20, False

.setRequestHeader "Cookie", strCookie

.send

strText = .responseText

End With

strText = Split(strText, "_preloadCallback(")(1)

strText = Left(strText, InStrRev(strText, ")") - 1)

objDOM.write ""

For i = 0 To objWindow.eval("data.msglist.length") - 1

k = k + 1

Set objList = objWindow.eval("data.msglist[" & i & "]")

lngCreateTime = CallByName(objList, "created_time", VbGet)

If Not objDIC.exists(lngCreateTime) Then

objDIC(lngCreateTime) = ""

Else

Exit Do

End If

Cells(k, 1) = CallByName(objList, "createTime", VbGet)

Cells(k, 2) = CallByName(objList, "content", VbGet)

Cells(k, 3) = CallByName(objList, "cmtnum", VbGet)

Next i

Loop

[A3:C3] = Array("日期", "说说", "评论人数")

Application.ScreenUpdating = True

strMsg = "用户：" & strUserName & vbCrLf & "您好!"

strMsg = strMsg & "目标QQ" & vntQQNum

strMsg = strMsg & "的说说数据已抓取完成。"

MsgBox strMsg

Set objIE = Nothing

Set objWINHTTP = Nothing

Set objDOM = Nothing

Set objWindow = Nothing

Set objDIC = Nothing

Set objList = Nothing

End Sub

Function strGetGTK(ByVal strKey As String) As String

Dim objNewDom As Object

Dim objNewWindow As Object

Dim strJSON As String

Set objNewDom = CreateObject("htmlfile")

Set objNewWindow = objNewDom.parentWindow

With objNewWindow

strJSON = "gtk=function(skey)"

strJSON = strJSON & ""

strJSON = strJSON & "('" & strKey & "');"

.execScript strJSON

strGetGTK = .gtk

End With

Set objNewWindow = Nothing

Set objNewDom = Nothing

End Function