はじめに
これは、Visual Basic Advent Calendar 2020とSpreadsheets/Excel Advent Calendar 2020の19日目の記事となります。
間に合わなかったので1日遅れになりました。
以前、「【Python】Youtube Data Apiを使ってYouTube 動画コメントを全取得する」の記事を書きました。
Excelでも出来るかなと思って今回やってみました。
環境
- Windows 10 Home
- Microsoft Office 365 の Excel
- VBA-JSON v2.3.1
- Microsoft Scripting Runtime
VBA-JSON
VBAではJSONをパースする標準ライブラリがないので、VBA-JSONを利用します。
https://github.com/VBA-tools/VBA-JSON
- Releasesから最新版(2020/12/19現在 v2.3.1)のVBA-JSONのリンクをクリックします。
- Source code(zip) をダウンロードして展開します。
- JsonConverter.basをVBAのプロジェクトにインポートします。
- 導入方法はVBAエディターを開き、プロジェクトウィンドウでVBAProjectを右クリックしファイルのインポートをクリックします。
- 標準モジュールにJsonConverterが表示されれば、VBA-JSONの導入は完了です。
図入りの説明が必要なら下記サイトを参照してください。
【VBA】Backlog APIで課題を操作する
Microsoft Scripting Runtime
- VBEメニューの [ ツール ] から [ 参照設定 ] を選択する。
- 表示された参照設定ダイアログから "Microsoft Scripting Runtime" にチェックを入れて[ OK ] ボタンをクリックする。
仕様
コメントのフォーマットはhtmlかplain textがあるのですが、plain textになっています。
並び順はrelevanceで評価順が多い順にしています。子コメントについては順不動(並び順を指定しても動画サイトと同じにならない)です。
※APIの使用回数を減らすため 親コメントはmaxResults=100、子コメントはmaxResults=50とする。
※コメントでは低評価(disLike)数は取得できない。
(連番) (親コメント) (グッド数) (投稿者名) (投稿日時) (返信数)
(連番) (子連番) (子コメント) (グッド数) (投稿者名) (投稿日時)
【2021/05/28追記】
並び順を評価順(relevance)にした場合、YouTube Data API v3の制約上2000件を超える親コメントが取得できません。
並び順を新しい順(time)にした場合、上限が不明ですが2000件を超える親コメントが取得できます。
使用方法
標準モジュールに、Constキーワードで'API_KEY'と'Video ID'を定義しているので変更してください。
VBAが出来る方なら、シートのセルに入力欄を作って変更できるようにすると楽になると思います。
'ここにAPI KEYを入力
Const API_KEY = "(API KEYを入力)"
'ここにVideo IDを入力
Const VIDEO_ID = "(Video IDを入力)"
私は、Sheet2にコマンドボタンを用意して、クリックしたらCall GetYoutubeComment
を呼ぶようにしています。
それか、マクロ実行でGetYoutubeComment
を実行すればいいです。
Sheet1にコメントが出力されます。
API_KEYを入力
Youtube Data APIのAPI有効化の認証情報でAPIキーが発行されるので、プログラムのAPI_KEYを入力で発行されたAPIキーに書き換えてください。
Video IDを入力
例えば、「https://www.youtube.com/watch?v=oeJ_b0iG9lM」であれば、oeJ_b0iG9lM
がVideo IDとなりますので、プログラムのVideo IDを入力で対象動画のVideo IDに書き換えてください。
プログラム
Option Explicit
Const URL = "https://www.googleapis.com/youtube/v3/"
'ここにAPI KEYを入力
Const API_KEY = "(API KEYを入力)"
'ここにVideo IDを入力
Const VIDEO_ID = "(Video IDを入力)"
Sub コメント取得_Click()
Call GetYoutubeComment
End Sub
' YouTube動画コメント全取得
Public Sub GetYoutubeComment()
Dim row As Integer
Dim header As Variant
Sheets(1).Activate
ActiveSheet.Cells.Clear
' ヘッダー
header = Array("連番", "子連番", "コメント", "グッド数", "投稿者名", "投稿日時", "返信数")
row = 1
Call Output(row, ActiveSheet, header)
Call GetComment(row, ActiveSheet)
End Sub
' コメント取得
Private Sub GetComment(ByVal row As Integer, ByVal sh As Worksheet)
Dim no As Integer, cno As Integer, json As Object
Dim text As String, like_cnt As Integer, user_name As String, post_date As Date
Dim total_reply_cnt As Integer, parentID As String
Dim params As Object, item As Object
Dim values As Variant
Set params = CreateObject("Scripting.Dictionary")
With params
.Add "key", API_KEY
.Add "part", "snippet"
.Add "videoId", VIDEO_ID
.Add "order", "relevance"
.Add "textFormat", "plaintext"
.Add "maxResults", "100"
.Add "pageToken", ""
End With
no = 1
Do While True
Set json = KickWebApiOfJson("GET", URL & "commentThreads", params)
For Each item In json("items")
' コメント
text = CStr(item("snippet")("topLevelComment")("snippet")("textDisplay"))
' グッド数
like_cnt = CInt(item("snippet")("topLevelComment")("snippet")("likeCount"))
' ユーザー名
user_name = CStr(item("snippet")("topLevelComment")("snippet")("authorDisplayName"))
' 投稿日時
post_date = JsonDateToDate(item("snippet")("topLevelComment")("snippet")("publishedAt"))
' 総返信数
total_reply_cnt = CInt(item("snippet")("totalReplyCount"))
' 親ID
parentID = CStr(item("snippet")("topLevelComment")("id"))
values = Array(no, "", text, like_cnt, user_name, post_date, total_reply_cnt)
Call Output(row, sh, values)
If total_reply_cnt > 0 Then
Call GetReplyComment(parentID, no, row, sh)
End If
no = no + 1
Next
params("pageToken") = CStr(json("nextPageToken"))
If params("pageToken") = "" Then
Exit Do
End If
Loop
End Sub
' 返信コメント取得
Private Sub GetReplyComment(ByVal parentID As String, ByVal no As Integer, ByRef row As Integer, ByVal sh As Worksheet)
Dim cno As Integer, json As Object
Dim text As String, like_cnt As Integer, user_name As String, post_date As Date
Dim params As Object, item As Object
Dim values As Variant
Set params = CreateObject("Scripting.Dictionary")
With params
.Add "key", API_KEY
.Add "part", "snippet"
.Add "videoId", VIDEO_ID
.Add "textFormat", "plaintext"
.Add "maxResults", "50"
.Add "pageToken", ""
.Add "parentId", parentID
End With
cno = 1
Do While True
Set json = KickWebApiOfJson("GET", URL & "comments", params)
For Each item In json("items")
' コメント
text = CStr(item("snippet")("textDisplay"))
' グッド数
like_cnt = CInt(item("snippet")("likeCount"))
' ユーザー名
user_name = CStr(item("snippet")("authorDisplayName"))
' 投稿日時
post_date = JsonDateToDate(item("snippet")("publishedAt"))
values = Array(no, cno, text, like_cnt, user_name, post_date)
Call Output(row, sh, values)
cno = cno + 1
Next
params("pageToken") = CStr(json("nextPageToken"))
If params("pageToken") = "" Then
Exit Do
End If
Loop
End Sub
' Excelシートに出力
Private Sub Output(ByRef row As Integer, ByVal sh As Worksheet, ByVal values As Variant)
Dim i As Integer
For i = 0 To UBound(values)
sh.Cells(row, i + 1).Value = values(i)
Next
row = row + 1
End Sub
' JSON日付変換
Private Function JsonDateToDate(ByVal dt As String) As Date
JsonDateToDate = CDate(Replace(Mid(dt, 1, 16), "T", " "))
End Function
' クエリ文字列変換
Private Function ConvertToQueryString(ByVal dic As Object) As String
If dic Is Nothing Then Exit Function
Dim key As Variant
Dim str As String
str = ""
For Each key In dic.Keys
ConvertToQueryString = ConvertToQueryString & str & key & "=" & dic.item(key)
str = "&"
Next
End Function
' WebAPI取得
Function KickWebApiOfJson(ByVal request As String, ByVal URL As String, Optional ByVal param As Object) As Object
Dim json
json = ConvertToQueryString(param)
Dim http As Object
Set http = CreateObject("MSXML2.ServerXMLHTTP")
With http
.Open request, URL & "?" & json, False
.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
.send
If .ResponseText <> "" Then
Set KickWebApiOfJson = ParseJson(.ResponseText)
End If
End With
End Function
実行結果
郡司りかさんを御存知でしょうか?
マツコ・デラックスさんと村上信五(関ジャニ∞)さんがMCの「月曜から夜更かし」の中で、運動音痴として注目を浴びた女性です。
郡司りかさんはYoutubeとTwitterをやられており、ツイート画像に「おはよー」を隠すという遊びをしています。
郡司りかさんのツイート画像の「おはよー」を見つける
「【NiziU】郡司さんMake You Happyにチャレンジ (練習前)」の動画コメントを取得すると、下記のようになります。
悩んだところ
YouTube Data Apiの呼び出し
sendのところにクエリパラメーターを指定すると、エラーコード 403、エラーメッセージ「The request is missing a valid API key.」で取得できなかったんですよね。
何か悪さしているんだろうけど、分からなかったです。
最終的に「URL & "?" & json」のようにクエリパラメーターを文字列連結して対応しました。
.Open request, URL, False
.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
.send json
返信コメントの取得
返信コメントは5件までだったら、item("snippet")("replies")("comments")
の配下で取得出来るはずなんですが、駄目でした。取得できるならもう少し高速化できたんですけどね。
Google App Scriptでは取得出来るので、VBA-JSON側で取れないのかも知れません。
Google Apps ScriptとYoutubeのAPIを利用して動画のコメントを取得する
最後に
VBA-JSONは、素晴らしいライブラリです。Excelでjson扱うんだったら素直に使った方がいいです。
Macのofficeを持っているのですがMacだとActiveXが使えません。「Microsoft Scripting Runtime」はDictionary型を使用するのに必要で、代わりになるものとして、VBA-toolsにVBA-Dictionaryがあります。
今度は、MacのOfficeで同じことが出来るのか試してみたいと思います。
【2020/12/21追記】
Mac版を作成しました。
【VBA】Excel for MacでYoutube Data Apiを使ってYouTube 動画コメントを全取得する