スポーツナビプロ野球一球速報のコメントをExelで表示
楽天の試合をニコ生で見ているとビジターの時はコメントなくて物足りなくなってしまうね。スポナビの一球速報のコメントをみたりしているんだけど余白が多くて一度に3つぐらいのコメントしか見れないのが不満だったからExcelで表示できるようにしてみたよ。A1 取得間隔(秒)B1 1行の文字数C1 ホーム側コメント色 1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色D1 ビジター側コメント色 1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色E1 URLExcel2000以外でちゃんと動作するかどうかわからないけどVBAはこんな感じ。無限Loopなので停止するときはctrl+Break。Sub スポナビ()On Error GoTo ErrorTrapDim oHttp As ObjectDim strURL As StringDim strText As StringDim arrData() As StringDim GetText As StringDim wIdx1 As LongDim wRow As LongDim wMaxRow As LongDim wStrno As LongDim wEndno As LongDim coment As StringDim comentd As StringDim comentn As LongDim comentmax As LongDim iro As LongDim mojisu As LongDim start As LongDim xxx(0) As StringDim i As IntegerDim StrFN As StringSheets("Sheet2").Select strURL = Cells(1, 5) mojisu = Cells(1, 2)Do comentmax = Cells(2, 4) 'クリア wMaxRow = Cells(Rows.Count, 5).End(xlUp).Row If wMaxRow < 2 Then wMaxRow = 2 Range("A2:" & "E" & wMaxRow).ClearContents wRow = 2 wStrno = 1 'オブジェクト変数に参照セットする Set oHttp = CreateObject("MSXML2.XMLHTTP") With oHttp 'URL読み込み .Open "GET", strURL, False 'キャッシュが読み込まれないように .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT" .send If (.Status < 200 Or .Status >= 300) Then 'ステータスのチェック MsgBox "URL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!" Set oHttp = Nothing GoTo ExitTrap End If If InStr(1, .ResponseText, "野球実況掲示板") = 0 Then '野球実況掲示板かどうかチェック MsgBox "時系列データが見つかりません", vbInformation + vbOKOnly Set oHttp = Nothing GoTo ExitTrap End If For i = 1 To 15 '最大取得コメント数は15にしている 'HTMLソースから[コメントNo]取り出し Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<div class=""comment"" data-comment=""", """>") Cells(wRow, 4) = GetText comentn = GetText wStrno = wEndno + 1 'HTMLソースからコメントがホーム側かビジター側かで色を変える Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<div class=""teamFlag""><span class=""", """></span></div>") iro = Cells(1, 3) If InStr(1, GetText, "home") = 0 Then iro = Cells(1, 4) wStrno = wEndno + 1 'HTMLソースからコメント切り出し Call 文字列抽出(wStrno, wEndno, GetText, .ResponseText, "<p class=""comText"">", "</p>") strText = GetText wStrno = wEndno + 1 'コメントの1行区切りごとに配列セット arrData = Split(strText, "<br />", , vbTextCompare) For wIdx1 = LBound(arrData) To UBound(arrData) coment = Replace(arrData(wIdx1), vbLf, "") '改行削除 coment = Replace(arrData(wIdx1), vbCrLf, "") '改行削除 coment = Replace(coment, ">", ">") '> を < に変換 coment = Replace(coment, "…", "…") '… を … に変換 coment = Replace(coment, "→", "→") '→ を → に変換 'コメントを指定文字数毎に区切って表示 start = 1 Do comentd = Mid(coment, start, mojisu) If comentd = "" Then Exit Do If comentd = " " Then Exit Do Cells(wRow, 5) = comentd Cells(wRow, 5).Font.ColorIndex = iro wRow = wRow + 1 start = start + mojisu Loop Next wIdx1 wRow = wRow + 1 If wRow > 30 Then Exit For '最大行数は約30行にしている Next i End With ExitTrap: 'オブジェクト変数を解放する Set oHttp = Nothing 'セルA1*1秒間待つ For i = 1 To Cells(1, 1) * 2 DoEvents Application.Wait [Now() + "0:00:00.5"] Next iLoopExit SubErrorTrap: 'エラー処理 MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!" Resume ExitTrap End SubSub 文字列抽出(ByRef wStrno As Long, ByRef wEndno As Long, ByRef GetText As String, prmAllText As String, prmStrText As String, prmEndText As String) '全体文字列(prmAllText)の中から開始文字列(prmStrText)~終了文字列(prmEndText)までの間の文字を取得する wStrno = InStr(wStrno, prmAllText, prmStrText) + Len(prmStrText) '開始文字列の次の文字位置を取得する wEndno = InStr(wStrno, prmAllText, prmEndText) '終了文字列の位置を取得する GetText = Mid(prmAllText, wStrno, wEndno - wStrno) '開始文字列~終了文字列までの間の文字を取得するEnd Sub