ニュースフィード画面を表示するVBAを記述する
GETメソッドで、ニュースフィード画面のデータをリクエストします。
［リスト2］ニュースフィード画面を表示するVBA
Option Explicit
'(1)定数の設定
Const userID = "（ユーザID）"
Const actoken = "（アクセストークン）"
Const baseUrl = "https://graph.facebook.com/"
Private Sub cbHome_Click()
'(2)ニュースフィード画面のリクエスト
Dim jsonFriend As String, jsonMe As String, status As String
'友達のフィードを取得
status = SendHttp("GET", baseUrl & userID & "/home?access_token=" & actoken, jsonFriend)
If status <> "OK" Then MsgBox ("リクエストが失敗しました。" & status): Exit Sub
'自分のフィードを取得
status = SendHttp("GET", baseUrl & userID & "/feed?access_token=" & actoken, jsonMe)
If status <> "OK" Then MsgBox ("リクエストが失敗しました。" & status): Exit Sub
'前回の検索結果をクリア
Dim resRow1 As Integer
resRow1 = 0
Dim resRow2 As Integer
Range("ttlName").Offset(1).Activate
resRow1 = ActiveCell.row
resRow2 = ActiveCell.SpecialCells(xlCellTypeLastCell).row
If resRow1 <= resRow2 Then Rows(resRow1 & ":" & resRow2).Delete
'(3)JScript関数の定義
Dim js As New ScriptControl
js.Language = "JScript"
Dim cd As String: cd = ""
cd = cd & "function getJson(obj){" & vbCrLf
cd = cd & " return eval('(' + obj + ')');" & vbCrLf
cd = cd & "}"
cd = cd & "function propEx(obj,prop){" & vbCrLf
cd = cd & " return (prop in obj);" & vbCrLf
cd = cd & "}"
js.AddCode cd
'(4)JSONデータを解析し、オブジェクト変数に格納
Dim objJsonFriend As Object, objJsonMe As Object
Set objJsonFriend = js.CodeObject.getJson(jsonFriend)
Set objJsonMe = js.CodeObject.getJson(jsonMe)
'(5)解析済みのJSONデータの件数を取得
Dim objDataFriend As Object, objDataMe As Object
Dim objRowCountFriend As Integer, objRowCountMe As Integer
Set objDataFriend = CallByName(objJsonFriend, "data", VbGet)
objRowCountFriend = CallByName(objDataFriend, "length", VbGet)
Set objDataMe = CallByName(objJsonMe, "data", VbGet)
objRowCountMe = CallByName(objDataMe, "length", VbGet)
'(6)結果をワークシートへ転記
Dim row As Integer: row = 0
Dim idxFriend As Integer: idxFriend = 0
Dim idxMe As Integer: idxMe = 0
Dim objRow As Object, objRowFriend As Object, objRowMe As Object
Application.ScreenUpdating = False
Do While idxFriend + idxMe <= objRowCountFriend - 1 + objRowCountMe - 1 'データの件数だけ繰り返す
'(7)JSONデータ1件分を取り出し、オブジェクト変数に格納
If idxFriend = objRowCountFriend Then '友達のフィードが処理終了の場合
Set objRow = CallByName(objDataMe, idxMe, VbGet) '自分のフィードを処理
idxMe = idxMe + 1
ElseIf idxMe = objRowCountMe Then '自分のフィードが処理終了の場合
Set objRow = CallByName(objDataFriend, idxFriend, VbGet) '友達のフィードを処理
idxFriend = idxFriend + 1
Else
'友達と自分のフィードをそれぞれ一旦取得
Set objRowFriend = CallByName(objDataFriend, idxFriend, VbGet)
Set objRowMe = CallByName(objDataMe, idxMe, VbGet)
'日時データがない方を処理対象とする（どちらもない場合は友達フィード優先）
If js.CodeObject.propEx(objRowFriend, "created_time", VbGet) = False Then
Set objRow = CallByName(objDataFriend, idxFriend, VbGet)
idxFriend = idxFriend + 1
ElseIf js.CodeObject.propEx(objRowMe, "created_time", VbGet) = False Then
Set objRow = CallByName(objDataMe, idxMe, VbGet)
idxMe = idxMe + 1
Else '双方、日時データがある場合は、新しい方を処理対象とする
If CallByName(objRowFriend, "created_time", VbGet) _
>= CallByName(objRowMe, "created_time", VbGet) Then
Set objRow = CallByName(objDataFriend, idxFriend, VbGet)
idxFriend = idxFriend + 1
ElseIf js.CodeObject.propEx(objRowMe, "created_time", VbGet) Then
Set objRow = CallByName(objDataMe, idxMe, VbGet)
idxMe = idxMe + 1
End If
End If
End If
If Not js.CodeObject.propEx(objRow, "message") Then GoTo lblContinue
row = row + 1
If js.CodeObject.propEx(objRow, "from") Then
Dim objFrom As Object
Set objFrom = CallByName(objRow, "from", VbGet)
If js.CodeObject.propEx(objFrom, "name") Then
Range("ttlName").Offset(row, 0) = CallByName(objFrom, "name", VbGet)
End If
End If
If js.CodeObject.propEx(objRow, "created_time") Then
Range("ttlDate").Offset(row, 0) = timeConv(CallByName(objRow, "created_time", VbGet))
End If
Range("ttlType").Offset(row, 0) = "【投稿】"
If js.CodeObject.propEx(objRow, "id") Then
Range("ttlId").Offset(row, 0) = CallByName(objRow, "id", VbGet)
End If
Range("ttlBody").Offset(row, 0) = CallByName(objRow, "message", VbGet)
'(8)いいね！データがあった場合の処理
If js.CodeObject.propEx(objRow, "likes") Then
Dim objLike As Object
Set objLike = CallByName(objRow, "likes", VbGet)
If js.CodeObject.propEx(objLike, "data") Then
Dim objLikeData As Object
Set objLikeData = CallByName(objLike, "data", VbGet)
Dim objLikeDataLen As Integer
objLikeDataLen = CallByName(objLikeData, "length", VbGet)
If objLikeDataLen > 0 Then
Dim idxLike As Integer
For idxLike = 0 To objLikeDataLen - 1
Dim objLikeDataRow As Object
Set objLikeDataRow = CallByName(objLikeData, idxLike, VbGet)
If js.CodeObject.propEx(objLikeDataRow, "name") Then
row = row + 1
Range("ttlType").Offset(row, 0) = "いいね！"
Range("ttlName").Offset(row, 0) = CallByName(objLikeDataRow, "name", VbGet)
End If
Next
End If
End If
End If
'(9)コメントデータがあった場合の処理
If js.CodeObject.propEx(objRow, "comments") Then
Dim objComm As Object
Set objComm = CallByName(objRow, "comments", VbGet)
If js.CodeObject.propEx(objComm, "data") Then
Dim objCommData As Object
Set objCommData = CallByName(objComm, "data", VbGet)
Dim objCommDataLen As Integer
objCommDataLen = CallByName(objCommData, "length", VbGet)
If objCommDataLen > 0 Then
Dim idxComm As Integer
For idxComm = 0 To objCommDataLen - 1
Dim objCommDataRow As Object
Set objCommDataRow = CallByName(objCommData, idxComm, VbGet)
If js.CodeObject.propEx(objCommDataRow, "message") Then
row = row + 1
Range("ttlType").Offset(row, 0) = "コメント"
If js.CodeObject.propEx(objCommDataRow, "from") Then
Dim objCommDataRowFrom As Object
Set objCommDataRowFrom = CallByName(objCommDataRow, "from", VbGet)
Range("ttlName").Offset(row, 0) = CallByName(objCommDataRowFrom, "name", VbGet)
End If
Range("ttlDate").Offset(row, 0) = timeConv(CallByName(objCommDataRow, "created_time", VbGet))
Range("ttlBody").Offset(row, 0) = CallByName(objCommDataRow, "message", VbGet)
End If
Next
End If
End If
End If
lblContinue:
Loop
Selection.CurrentRegion.WrapText = True
Application.ScreenUpdating = False
Set objJsonFriend = Nothing
Set objJsonMe = Nothing
Set js = Nothing
End Sub
(1)まず定数の設定をしておきます。(ユーザID)(アクセストークン)の部分は、ご自分で取得したものに置き換えてください。
続いて、cbHome(ニュースフィードを表示)ボタンをクリックした際のVBAを記述します。
(2)SendHttpユーザ定義関数を使ってリクエストを行います。json変数に、ニュースフィード表示のデータがJSON形式の文字列として入ります。表3で示したように、友達のフィードと自分のフィードとは、別々のURLでアクセスする必要があるため、それぞれ、jsonFriend、jsonMeのように、変数名の後ろにFriend、Meを付けて区別します(以下すべての変数で同様)。
(3)ユーザ定義関数をJScriptで作っておきます。getJsonは、JSON形式の文字列を受け取り、eval関数により変換したJSONオブジェクトを返します。propExは、仮引数objにオブジェクト、propにプロパティ名を受け取り、(prop in obj)によりJSONオブジェクトのプロパティの存否を真偽値として返します。
(4)文字列のjsonをgetJsonユーザ定義関数で解析し、結果をobjJsonに格納します。Facebookからのデータは以下のような構造になっています。
 |
図12．Facebookのデータ構造 |
(5)JSONオブジェクトについては、CallByName(オブジェクト,プロパティ名,VbGet)でプロパティを取得できるのでした（第13回のJScriptを参照）。
投稿1件分はdata要素として得られますので、data配列をobjData変数に取り込んだ上、lengthプロパティにより、配列サイズをobjRowCount変数に格納します。
(6)data要素には投稿に対するコメントや「いいね！」も含まれます。これらもワークシートの新しい行に転記しますので、行数カウンタrow変数を用意しておきます。続いて投稿の件数だけ繰り返す処理を行います。
(7)投稿1件分をobjRow変数に取り出します。この際、友達のフィードと自分のフィードとは、objRowFriendとobjRowMeに分かれて格納させているので、日付の新しい順にマージしながら、対象データをobjRowに格納して後続の処理を行います。
data配列のidx番目の要素は通常data[idx]と書きますが、プロパティにアクセスするようにdata.idxとも書けますので、CallByName(オブジェクト,インデックス,VbGet)で要素にアクセスできます。
本文（message）のない投稿は対象外としたいので、(3)で定義したpropEx関数でチェックし、TRUEの場合のみrow変数をインクリメントし、処理を続行します。
まず、from→nameとたぐり投稿者の名前を、created_timeから投稿日時を、idから投稿IDを、messageから投稿本文を、投稿種別として"【投稿】"をそれぞれ、対応するセルに転記します。
(8)「いいね！」があれば、likes要素内のdata配列に存在します。lengthプロパティが1以上ならその数だけ処理を繰り返します。name要素があればrow変数をインクリメントし、nameから投稿者の名前を、投稿種別として"いいね！"を、対応するセルに転記します。
(9)コメントがあれば、comments要素内のdata配列に存在します。lengthプロパティが1以上ならその数だけ処理を繰り返します。コメントは投稿と同じ構造なので、処理も投稿と同様に行います。投稿種別は"コメント"を転記します。
