JRAのホームページから、
ワイドと三連複のオッズを取得したい
と質問があったので、
まず、ワイドのオッズ取得にチャレンジしてみます。
私Ken3が大好きだったIEのサポートが終了したので、
MSXML2.XMLHTTP
と
CreateObject("htmlfile")を使用して
JRAオッズ取得 ワイドのオッズ取得に挑戦してみました。
#JRA #競馬 #オッズ取得 #ワイドオッズ
#IEサポート終了 #MSXML2.XMLHTTP #htmlfile #デバッグ
#ExcelVBA #MSExcel
下記、いつもの解説動画です。
とても※長いので休憩を取りながら、ソースコードと一緒にみてください。
途中コーヒー休憩、ブレイクタイム必要です。ぉぃぉぃ。
www.youtube.com
https://www.youtube.com/watch?v=XnIN8XRi-yA
目次
00:00 あいさつ 実行結果 やりたいこと
01:55 1.開催日・場所は、流用する
10:08 2.ワイドのオッズを押す
11:55 2.1 strレースを探し、頭出し?
18:47 3.オッズのテーブルを判断して、Excelにワイドオッズを取得
21:37 3.1 tableのcaptionで判断
28:30 4.ワイドの一番人気を探す
31:17 元に戻って、2.4 2回目以降は、レースを選択
視聴者の声:「30分は、長いなぁ・・・」
Ken3:次回からは、ポイントをまとめるように努力します。(※努力義務で逃げるのかよ、大人って汚いな・・・)
あいさつ 実行結果 やりたいこと
まず、ワイドのオッズ取得に挑戦してみます。
1.開催日・場所は、流用する
単勝オッズの取得から、
開催日と場所の選択は単勝オッズ取得から流用しました。
ken3memo.hatenablog.com
↑に前回の単勝オッズのVBAソースコードがあるので、合わせてみてください。
2.ワイドのオッズを押す
'リンクから、レースのTR行を探し、列 ここではワイドなどを返す 20220924追加修正
strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "ワイド")
みたいに、レースとワイドで指定したリンクを取り出す。
何言ってんだか・・・
オッズのリンクが
1R 単勝複勝 枠連 馬連 ワイド 馬単 3連複 3連単
2R 単勝複勝 枠連 馬連 ワイド 馬単 3連複 3連単
・
・
・
11R 単勝複勝 枠連 馬連 ワイド 馬単 3連複 3連単
12R 単勝複勝 枠連 馬連 ワイド 馬単 3連複 3連単
と、並んでいるので、
2.1 strレースを探し、頭出し?
2.2 次のリンクから、ワイドの文字を見つけるまで、ループ・・と処理してみた
2.3 言い訳
本当は、かっこよく、
レースを見つけたら、その行 TRを取り出して、
その中の列 TDを探す・・・なんて構想で、
関数名も調子よく
Public Function IE_Link_InnerHTML_InStr_TR_TD(oDocument As Object, _
strレース As String, _
str種類 As String) As String
と
IE_Link_InnerHTML_InStr_TR_TD
インナー、内側のHTMLから、TRとTDを探すっぼく書いてるけど、
あれれ、
If InStr(oDocument.Links(i).outerHTML, strレース) > 0 Then '内側のHTML
↑やじるし、
あっ、これは、やっちゃいけない、コメントで嘘ついてる。
'内側のHTML ?
実物は、
InStr(oDocument.Links(i).outerHTML で比べてるし・・・
これがうわさの、コメント信じるな、ソースはうそをつかない・・ですね。
話がそれたけど、
処理は、
レースを探してから、
次に来る ワイド の 文字を探しただけでした。
2.4 2回目以降は、レースを選択
複数レース取得の時は、
先頭ページに戻らないで、
そのまま、レースのみ選択する
※ワイドのオッズ表示のページにいるので、そこからレース選択のみでよい
strRACE = nRACE & "レース" '1Rなど 文字にする
'リンクから該当するレースを探しクリックする "1R".."12R"
If str初回FLG = "初回" Then '初回はレースとワイドを探す
'リンクから、レースのTR行を探し、列 ここではワイドなどを返す
strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "ワイド")
str初回FLG = "次はレース選択のみ" 'フラグを折る。何を入れてもいい
Else
'2回目以降は、レースのみ選択で良い。ワイドオッズの場所にいるので
'リンクから該当するレースを探しクリックする "1R".."12R"
'Call IE_Link_InnerHTML_InStr_Click(oDocument, """" & strRACE & """")
strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, strRACE)
End If
3.オッズのテーブルを判断して、Excelにワイドオッズを取得
21:37
3.1 tableのcaptionで判断
<table class="basic narrow-xy wide">
<caption>1</caption>
<tbody>
と、
テーブルのキャプションで判断する。
JRAさんのページはしっかり作られていて、勉強になりますね。
初めて、
object HTMLTableCaptionElement
Watch : - : objTABLEs(i) : "[object HTMLTableElement]" : Variant/Object/HTMLTable :
- : caption : : Variant/Object/HTMLTableCaption :
: innerText : "1" : Variant/String : Module6.ie_JRAワイドオッズをレース別に複数蓄積する
を使ってみた。
If objTABLEs(i).Caption.innerText = n馬番
みたいな感じで、
1から判断してみた。
3.2 あとは、いつもの objTABLE.Rows.Length で縦の行を移動させて書き込む
'表をDATAシートに書き出す 'テーブルからデータを抜き出す、書き出す For y = 0 To objTABLE.Rows.Length - 1 '行のループ 'データをセルに書く 馬番 - 馬番 ワイドオッズ Cells(SET_Y, 1) = objTABLEs(i).Caption.innerText '馬番 ここはテーブルのキャプション Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = objTABLE.Rows(y).Cells(0).innerText '馬番 Cells(SET_Y, 4) = objTABLE.Rows(y).Cells(1).innerText 'ワイドオッズ 10.1-11.2 など‐付きで入っているので、そのまま SET_Y = SET_Y + 1 Next y
28:30
4.ワイドの一番人気を探す
7.1-7.9
4.0-4.8
41.2-44.2
を手抜きで、
val("7.1-7.9")
とすると、7.1が取れるので、
比べてみた。
※1つのセルに入ってしまったので、桁がそろっていない
7.1- 7.9
41.2-44.2
4.0- 4.8
見た目を考えないとなぁ・・・
ソースコード全体を下に載せます、
アレンジして、使ってみてください。
IEサポート終了後の
MSXML2.XMLHTTP
と
CreateObject("htmlfile")を使用した処理
で何かの参考となれば幸いです。
Option Explicit '20220924 テスト Sub ie_JRAワイドオッズをレース別に複数蓄積する() 'ワイドの取得テスト ActiveWindow.WindowState = xlMinimized '最小表示 DoEvents Sleep 1000 '1秒待つ ActiveWindow.WindowState = xlNormal 'ノーマル表示 DoEvents 'JRA TOP ページの表示 '処理したいページをGET Dim strURL As String Dim strHTML As String strURL = "https://www.jra.go.jp/" strHTML = get_htmlfile(strURL) 'JRA TOPをGetする 'TOPページ文章に対して、処理を行います。 Dim i As Integer '添え字 i番目などで使用 Dim yLINE As Integer '行カウンタ、Y行目 Dim oDocument As Object Set oDocument = CreateObject("htmlfile") 'Set oDocument = New HTMLDocument '参照設定したとき 'oDocument.write "<html><body>test</body></html>" 'HTMLをセット 'Stop strHTML = Replace(strHTML, "script", "") 'scriptを止めるTEST oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ 'htmlfile_WAIT_TEST (oDocument) Dim objA As HTMLAnchorElement Dim objTABLEs As Object 'TABLE複数の格納用 Dim objTABLE As HTMLTable 'テーブル単体 Dim x As Integer '列の管理 Dim y As Integer '行の管理 Dim SET_Y As Integer 'Excel側のセット位置 Dim SET_X As Integer 'Excel側のセット位置 Dim objCELL As HTMLTableCell Dim nRACE As Integer 'レース 1-12 Dim strRACE As String '文字列 1Rなどを作るため Dim Waku_str As String Dim Waku_n As Integer 'リンクからオッズを押す Dim strLINK As String strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, "オッズ") If strLINK = "ERR" Then MsgBox "オッズが見つかりません" Stop End If 'オッズのページ HTMLを取り出す '<A onclick="doAction('/JRADB/accessO.html','pw15oli00/6D');return '文字列切り出し(strMOJI, "doAction('","','") '文字列切り出し(strMOJI, "','","')") Dim strPARA As String strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "','") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "','", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '開催日のリンクをあさる strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, Sheets("MENU").Range("B2")) If strLINK = "ERR" Then MsgBox Sheets("MENU").Range("B2") & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents '1R-12R ワイドの表を取り込む Dim rワイドの列 As Range '2022/09/24 一番人気を探すため Dim n一番人気 As Integer '一番人気の馬番受け取る。馬番=位置なんだけど・・・ Dim strWORK As String 'C1にセットする文字列を作る Dim n馬番 As Integer '馬は最大18頭 Dim str初回FLG As String '初回はワイドをチェック、次からはレースのみで良い str初回FLG = "初回" '初回で初期化 '1Rから12Rまで、ループする。※これだと前日発売の時1Rでトラブルなぁ For nRACE = 1 To 12 '一から十二まで 'B5からのフラグが立っていたら And 最終じゃなければ 'レースを取り込む If Sheets("MENU").Range("B4").Offset(nRACE, 0) = 1 _ And Sheets("MENU").Range("B4").Offset(nRACE, 1) <> "最終" Then '出力先をクリアする 'まず、書き込み先シート、データをクリアする 'Sheets(nRACE & "R").Select 'シートの切り替え Sheets("作業用").Select 'シートの切り替え Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 SET_Y = 0 'セット位置を初期化 strRACE = nRACE & "レース" '1Rなど 文字にする 'リンクから該当するレースを探しクリックする "1R".."12R" If str初回FLG = "初回" Then '初回はレースとワイドを探す 'リンクから、レースのTR行を探し、列 ここではワイドなどを返す strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "ワイド") str初回FLG = "次はレース選択のみ" 'フラグを折る。何を入れてもいい Else '2回目以降は、レースのみ選択で良い。ワイドオッズの場所にいるので 'リンクから該当するレースを探しクリックする "1R".."12R" 'Call IE_Link_InnerHTML_InStr_Click(oDocument, """" & strRACE & """") strLINK = IE_Link_InnerHTML_InStr_Click(oDocument, strRACE) End If If strLINK = "ERR" Then 'エラーチェック MsgBox strRACE & "が見つかりません" Stop End If strURL = "https://www.jra.go.jp" & 文字列切り出し(strLINK, "doAction('", "',") 'URL strPARA = "cname=" & 文字列切り出し(strLINK, "', '", "')") 'パラメーター strHTML = get_htmlfile_post(strURL, strPARA) 'パラメーターを付けて開く Set oDocument = Nothing Set oDocument = CreateObject("htmlfile") oDocument.write strHTML '取得したHTMLをセット DoEvents Sleep 1000 '1秒待つ DoEvents 'Call IE_WAIT(objIE) 'ページの表示完了を待ちます。 'レース番号をセルに書く SET_Y = SET_Y + 1 Cells(SET_Y, 1) = Sheets("MENU").Range("B2") & " " & strRACE Cells(SET_Y, 2) = JRA_Bodyからオッズの時刻を返す(oDocument) Sheets("MENU").Range("C4").Offset(nRACE, 0) = JRA_Bodyからオッズの時刻を返す(oDocument) Debug.Print "オッズ:" & JRA_Bodyからオッズの時刻を返す(oDocument) '発送時刻のセット 'JRA_Bodyから発走時刻を返す Sheets("MENU").Range("A4").Offset(nRACE, 0) = strRACE & "発走" & JRA_Bodyから発走時刻を返す(oDocument) Debug.Print strRACE & "発走:" & JRA_Bodyから発走時刻を返す(oDocument) SET_Y = SET_Y + 1 'ワイドの表を取り込む 表、テーブルを探る '見出しをセルに書く 馬番 - 馬番 ワイドオッズ Cells(SET_Y, 1) = "馬番" Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = "馬番" Cells(SET_Y, 4) = "ワイドオッズ" SET_Y = SET_Y + 1 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 For n馬番 = 1 To 17 '馬番は最大18頭、17-18が最後なのでMAX17までループ 'TABLEタグを抜き 複数のテーブルをセット Set objTABLEs = oDocument.getElementsByTagName("TABLE") '↑で代入したオブジェクトからテーブルデータを取り出す。 Set objTABLE = Nothing 'オブジェクトを空にする For i = 0 To objTABLEs.Length - 1 'テーブル数分回す 'テーブルのcaptionが処理する馬番かチェック If objTABLEs(i).Caption.innerText = n馬番 Then '一致したテーブルGet Set objTABLE = objTABLEs(i) 'みつけたらi番目を代入 Exit For End If Next i '↑で見つかったかチェックする If objTABLE Is Nothing Then '見つからなかったら、終わっていたら、ループを抜ける Exit For '抜ける End If '表をDATAシートに書き出す 'テーブルからデータを抜き出す、書き出す For y = 0 To objTABLE.Rows.Length - 1 '行のループ 'データをセルに書く 馬番 - 馬番 ワイドオッズ Cells(SET_Y, 1) = objTABLEs(i).Caption.innerText '馬番 ここはテーブルのキャプション Cells(SET_Y, 2) = "‐" Cells(SET_Y, 3) = objTABLE.Rows(y).Cells(0).innerText '馬番 Cells(SET_Y, 4) = objTABLE.Rows(y).Cells(1).innerText 'ワイドオッズ 10.1-11.2 など‐付きで入っているので、そのまま SET_Y = SET_Y + 1 Next y Next n馬番 SET_Y = SET_Y + 1 '空白を一行追加 '作業用シートからレース別に転記する Sheets(nRACE & "R").Select 'シートの切り替え '初回か判断 レース場や開催日が変わっているか判断 If Sheets("作業用").Range("A1") <> Range("A1") Then 'レース日や開催違いなら 'シートをクリア Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '初回は、開催場所、見出しもコピーする Sheets("作業用").Range("A1:D" & SET_Y).Copy 'SET_Yまでコピー Range("A1").Select ActiveSheet.Paste 'オッズの時刻をセット Sheets("作業用").Range("B1").Copy Range("D2").Select ActiveSheet.Paste Set rワイドの列 = Range("D2") '初回はD2をセット 2022/05/15 Else '二回目以降は、後ろに追記 '元データをコピー Sheets("作業用").Range("D2:D" & SET_Y).Copy 'オッズの列 '貼り付け先を探す For x = 1 To 256 '空白列を探す 'セル二行目のx列が空白か調べて抜ける If Len(Trim("" & Cells(2, x))) = 0 Then Exit For Next x Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste Set rワイドの列 = Cells(2, x) '貼り付けたx列をセット 2022/05/15 '時刻を貼り付ける Sheets("作業用").Range("B1").Copy Cells(2, x).Select '貼り付け先を選択 ActiveSheet.Paste End If '10倍以下を赤に、小数点をそろえ、一番人気を探す 2022/05/15 n一番人気 = ワイド一番人気を探す(rワイドの列) 'ワイドの列から一番人気を探す strWORK = "ワイドの一番人気は " strWORK = strWORK & Range("a2").Offset(n一番人気, 0) strWORK = strWORK & " ハイフン " strWORK = strWORK & Range("a2").Offset(n一番人気, 2) strWORK = strWORK & " オッズは " & rワイドの列.Offset(n一番人気, 0) & " です" Range("c1") = strWORK '読み上げる※動画用 DoEvents Range("B1").Clear Range("A1,C1").Speak 'A1とC1を読み上げ End If 'フラグが立っていたら↑ Next 'MENUに戻り、保存 Sheets("MENU").Select Range("A3").Select ActiveWorkbook.Save End Sub
'リンクから、レースのTR行を探し、列 ここではワイドなどを返す 20220924追加修正 'strLINK = IE_Link_InnerHTML_InStr_TR_TD(oDocument, strRACE, "ワイド") 'IEのリンクオブジェクトから文字列をInStrで探して返す Public Function IE_Link_InnerHTML_InStr_TR_TD(oDocument As Object, _ strレース As String, _ str種類 As String) As String Dim i As Integer Dim objA As HTMLAnchorElement Dim strWORK As String Dim n As Integer 'まず、リンクから受け取ったレース文字列を返す IE_Link_InnerHTML_InStr_TR_TD = "ERR" '初期値にERRセット For i = 0 To oDocument.Links.Length - 1 'レースの文字列を見つけたら クリックじゃなかった次の種類を探す If InStr(oDocument.Links(i).outerHTML, strレース) > 0 Then '内側のHTML '本当は、見つけた行、TRを取得して、その中のTDを探した方がかっこいいけど 'ここでは、カウンターのiを使い、iより後ろで見つかったものを返す 'iとnのループカウンタ、添え時に注意してね For n = i + 1 To oDocument.Links.Length - 1 'レースの文字列を見つけたら クリックじゃなかった次の種類を探す If InStr(oDocument.Links(n).outerHTML, str種類) > 0 Then '内側のHTML IE_Link_InnerHTML_InStr_TR_TD = oDocument.Links(n).outerHTML '見つけたAタグオブジェ(リンク)を代入 Exit For '↑同じ行TRのチェックしてないけど・・・ End If Next n Exit For '見つけたのでループを抜ける ↑が同じTR行内のチェックしてないけどね・・・ End If Next i Debug.Print "リターン:" & IE_Link_InnerHTML_InStr_TR_TD End Function '2022/09/24 追加 ワイドの列 先頭(見出しの部分)を受け取り一番人気を返す Public Function ワイド一番人気を探す(r As Range) As Integer Dim オッズ As Double Dim 一番人気 As Integer Dim n As Integer '初期値を代入 'val("10.1 - 11.5") みたいにすると変換されるので、Valで手抜き変換 オッズ = Val(r.Offset(1, 0)) '馬番1のオッズを初期値にする 一番人気 = 1 '上から1番目を初期セット For n = 1 To 18 * 17 'MAX18*17まわす、といっても途中で抜けるならForじゃなくても・・ With r.Offset(n, 0) 'n下のセルを操作したり値を比べる If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける '10倍以下なら、赤にする If Val(.Value) < 10 Then .Font.Color = -16776961 '赤にする End If 'オッズを比べる If Val(.Value) < オッズ Then '一時保存されているオッズより低かったら オッズ = Val(.Value) 'オッズを代入 更新 一番人気 = n '馬番nをセット End If End With Next ワイド一番人気を探す = 一番人気 'リターン値を返す '※まったく もう 日本語変数と関数名は良くないな・・・ End Function
前回単勝オッズから流用作成のコード
開催日と場所の選択は単勝オッズ取得から流用しました。
ken3memo.hatenablog.com
↑に前回の単勝オッズのVBAソースコードがあるので、合わせてみてください。
#If Win64 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If 'IEのリンクオブジェクトから文字列をInStrで探してクリックする Public Function IE_Link_InnerHTML_InStr_Click(oDocument As Object, strINSTR As String) As String Dim i As Integer Dim objA As HTMLAnchorElement Dim strWORK As String Dim n As Integer 'リンクから受け取った文字列を返す IE_Link_InnerHTML_InStr_Click = "ERR" '初期値にERRセット For i = 0 To oDocument.Links.Length - 1 '文字列を見つけたら クリック If InStr(oDocument.Links(i).outerHTML, strINSTR) > 0 Then '内側のHTML IE_Link_InnerHTML_InStr_Click = oDocument.Links(i).outerHTML '見つけたAタグオブジェ(リンク)を代入 Exit For '見つけたのでループを抜ける End If Next i End Function Public Function JRA_Bodyからオッズの時刻を返す(oDocument As Object) As String Dim strTEMP As String Dim strRETURN As String 'リターン値 Dim n As Integer 'errでリターン値を初期化 strRETURN = "ERR 文字列が見つかりませんでした" 'HTMLのBODYテキストを代入 strTEMP = oDocument.body.innerText 'まず最終オッズを探す If InStr(strTEMP, "最終オッズ") > 0 Then strRETURN = "最終" End If '探す 13時03分現在オッズ 2018/12/09 修正 '次週確認 7時03分現在オッズ 一けた台の時刻の時 n = InStr(strTEMP, "現在オッズ") If n > 0 Then strRETURN = Mid(strTEMP, n - 6, 6) '時刻を取り出す End If 'リターン値をセット strRETURN = Replace(strRETURN, vbLf, "") '改行vblfを""消す JRA_Bodyからオッズの時刻を返す = strRETURN End Function Public Function JRA_Bodyから発走時刻を返す(oDocument As Object) As String Dim strTEMP As String Dim strRETURN As String 'リターン値 Dim n As Integer 'errでリターン値を初期化 strRETURN = "発走時刻が見つかりませんでした" 'HTMLのBODYテキストを代入 strTEMP = oDocument.body.innerText '5回中山4日 発走時刻:13時05分 n = InStr(strTEMP, "発走時刻") If n > 0 Then strRETURN = Mid(strTEMP, n + 5, 6) '後ろの時刻を取り出す End If 'リターン値をセット JRA_Bodyから発走時刻を返す = strRETURN End Function 'URLを受け取り、HTML文字列を返す(シフトJISページ用に変換後) Public Function get_htmlfile(strURL As String) As String Dim objDOC As Object Set objHTML = CreateObject("MSXML2.XMLHTTP") objHTML.Open "GET", strURL, False 'objHTML.overrideMimeType "text/plain; charset=Shift_JIS" DoEvents objHTML.send Sleep 250 '0.25秒待つ DoEvents Do While objHTML.readyState <> 4 DoEvents Loop Dim strHTML As String 'strHTML = objHTML.responseText strHTML = StrConv(objHTML.responseBody, vbUnicode) 'テキスト確認 デバッグ用 Dim strFNAME As String strFNAME = ThisWorkbook.Path & "\testhtml.txt" Open strFNAME For Output As #1 Print #1, Now() & " に実行" Print #1, "strURL:" & strURL Print #1, strHTML Close #1 'Debug.Print strHTML Sleep 250 '0.25秒待つ get_htmlfile = strHTML 'リターン値で返す End Function 'URL,パラメータを受け取り、HTML文字列を返す(シフトJISページ用に変換後) Public Function get_htmlfile_post(strURL As String, strPARA As String) As String Dim objHTML As Object Set objHTML = CreateObject("MSXML2.XMLHTTP") objHTML.Open "POST", strURL, False objHTML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" objHTML.send (strPARA) DoEvents Sleep 250 '0.25秒待つ DoEvents Do While objHTML.readyState <> 4 DoEvents Loop Dim strHTML As String 'strHTML = objHTML.responseText strHTML = StrConv(objHTML.responseBody, vbUnicode) 'テキスト確認 デバッグ用 Dim strFNAME As String strFNAME = ThisWorkbook.Path & "\testhtml.txt" Open strFNAME For Output As #1 Print #1, Now() & " に実行" Print #1, "strURL:" & strURL Print #1, "strPARA:" & strPARA Print #1, strHTML 'HTML Close #1 'Debug.Print strHTML get_htmlfile_post = strHTML 'リターン値で返す End Function
'左右のキーワードを受け取り、文字を切り出す '<A onclick="doAction('/JRADB/accessO.html','pw15oli00/6D');return '文字列切り出し(strMOJI, "doAction('","','") '文字列切り出し(strMOJI, "','","')") Public Function 文字列切り出し(strMOJI As String, strLEFT As String, strRIGHT As String) As String 文字列切り出し = "" 'データ無しで初期化 Dim nLEFT As Integer Dim nSTART As Integer Dim n As Integer '左側の位置を探す n = InStr(strMOJI, strLEFT) '左側の区切り文字を探す If n = 0 Then Exit Function '見つからない時抜ける '開始位置をセット nSTART = n + Len(strLEFT) '抜き取り開始位置 '右側キーワードを探す n = InStr(nSTART, strMOJI, strRIGHT) '右側の区切り文字を探す If n = 0 Then Exit Function '見つからない時抜ける 'MIDで抜き出す 文字列切り出し = Mid(strMOJI, nSTART, (n - nSTART)) End Function '2022/05/15 追加 単勝の列 先頭(見出しの部分)を受け取り一番人気を返す 'ついでに 10倍以下のオッズを赤に、小数点の桁をそろえる Public Function 単勝一番人気を探す(r As Range) As Integer Dim オッズ As Double Dim 一番人気 As Integer '初期値を代入 オッズ = r.Offset(1, 0) '馬番1のオッズを初期値にする 一番人気 = 1 '馬番1を初期セット For n = 1 To 18 'MAX18頭まわす、といっても途中で抜けるならForじゃなくても・・ With r.Offset(n, 0) 'n下のセルを操作したり値を比べる If Len(Trim("" & .Value)) = 0 Then Exit For 'データ無しなら抜ける '99.9 と 小数点の桁をそろえる .NumberFormatLocal = "0.0" '10倍以下なら、赤にする If .Value < 10 Then .Font.Color = -16776961 '赤にする End If 'オッズを比べる If .Value < オッズ Then '一時保存されているオッズより低かったら オッズ = .Value 'オッズを代入 更新 一番人気 = n '馬番nをセット End If End With Next 単勝一番人気を探す = 一番人気 'リターン値を返す '※まったく もう 日本語変数と関数名は良くないな・・・ End Function
関連動画のリスト
1.
CreateObject("htmlfile")でDocumentを作りweb上のhtmlデータを抜き出す 例としてJRAのHPからオッズを取得してみた
https://www.youtube.com/watch?v=RjZZUq40gxY
2.
JRAホームページ「onClick=doAction が なんでPOSTだとわかったんですか?」と質問されたので
https://www.youtube.com/watch?v=NPnKju8rkVw
3.
VBScript 定期実行 タスクスケジューラの設定テスト 終了設定でつまづく VBSを5分単位で実行させてみた
https://www.youtube.com/watch?v=4IkuWVECTVo
4.
ExcelVBAで表示変更 10倍以下を赤 小数点を0.0でそろえる 例題:JRA 単勝オッズ取得
https://youtu.be/rAi_uL41Bp0
5.
Excel 読み上げ Range(範囲).Speak で簡単にできます Application.Speech.Speakもアリかな
https://www.youtube.com/watch?v=c4mH9szOo2w