2017/06/16
テーマ： パソコンを楽しむ♪(3590)
カテゴリ： パソコン
楽天の試合をニコ生で見ているとビジターの時はコメントなくて物足りなくなってしまうね。
スポナビの一球速報のコメントをみたりしているんだけど余白が多くて一度に３つぐらいのコメントしか見れないのが不満だったから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。
スポナビの一球速報のコメントをみたりしているんだけど余白が多くて一度に３つぐらいのコメントしか見れないのが不満だったから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
お気に入りの記事を「いいね！」で応援しよう
[パソコン] カテゴリの最新記事
-
Mini PC 購入 Beelink SEi12 Intel i5-12… 2023/11/15
-
24インチ液晶モニター DELL P2416D 購入 2023/02/09
-
Windows11対応タブレット NEC VKE11-U4 購… 2022/10/10
【毎日開催】
15記事にいいね！で1ポイント
PR
Keyword Search
▼キーワード検索
Calendar
令和６年度女性防災…
防災宮城さん
サラリーマンってム… ロデ男0166さん
僕のIT活用と勝手な話 LungYaiさん
おためしブログ～自… Tanukidadさん
ひっこりんの冒険 ひっこりんさん
サラリーマンってム… ロデ男0166さん
僕のIT活用と勝手な話 LungYaiさん
おためしブログ～自… Tanukidadさん
ひっこりんの冒険 ひっこりんさん
Free Space
© Rakuten Group, Inc.
