|
|
|
2017/06/16
テーマ：パソコンを楽しむ♪(3523)
カテゴリ：パソコン
楽天の試合をニコ生で見ているとビジターの時はコメントなくて物足りなくなってしまうね。
スポナビの一球速報のコメントをみたりしているんだけど余白が多くて一度に３つぐらいのコメントしか見れないのが不満だったからExcelで表示できるようにしてみたよ。   A1 取得間隔（秒） B1 1行の文字数 C1 ホーム側コメント色 1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色 D1 ビジター側コメント色 1:黒 2:白 3:赤 4:緑 5:青 6:黄 7:紫 8:水色 E1 URL Excel2000以外でちゃんと動作するかどうかわからないけどVBAはこんな感じ。 無限Loopなので停止するときはctrl+Break。 Sub スポナビ() On Error GoTo ErrorTrap Dim oHttp As Object Dim strURL As String Dim strText As String Dim arrData() As String Dim GetText As String Dim wIdx1 As Long Dim wRow As Long Dim wMaxRow As Long Dim wStrno As Long Dim wEndno As Long Dim coment As String Dim comentd As String Dim comentn As Long Dim comentmax As Long Dim iro As Long Dim mojisu As Long Dim start As Long Dim xxx(0) As String Dim i As Integer Dim StrFN As String Sheets("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 i Loop Exit Sub ErrorTrap: 'エラー処理 MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!" Resume ExitTrap End Sub Sub 文字列抽出(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
お気に入りの記事を「いいね！」で応援しよう
Last updated
2017/06/16 07:35:27 PM
コメント(0) | コメントを書く
[パソコン] カテゴリの最新記事
|
|
