2009-04-18 三流解説 VBA IE JRA IPATのページから単勝の表を取り込む サンプルプログラム

Excel UserForm に WebBrowserを貼り、
JRA IPAD から 単勝オッズの作成を開始しました。
前回までの記事は→[2009-04-05 表の取り込み]を見てください。
最新情報と作成履歴は→[更新履歴と最新を表示]
実行可能なサンプルファイルは:[IE_UMA_0418.zip]←サンプルの IE_UMA_0418.xls です。

開催地を１シートにして、1R-12Rまで単勝オッズを取り込む

やっと、部品？がそろったので、
開催地をシート別にして、単勝オッズを取り込んでみたいと思います。

Option Explicit

Private Sub bGET_TAN_Click()
    Dim n       As Integer 'ループのカウンター
    
  '情報メニューの起動。
    Call jMENU_Click '情報メニューを起動する(クリックする)
    
  '開催レース名を取り込む。
  
    Dim objNAMEm As Object  'm レース場、開催地の選択オブジェクト
    Dim strJYOMEI(10) As String  '開催地の名前を保存する
    Dim nMAXJYOMEI As Integer    '開催地の数を保存する。
    
    '名前がmのオブジェクトを.getElementsByName("m")で取得。
    Set objNAMEm = Me.WebBrowser1.Document.getElementsByName("m")  'HTML文章から名前がmのオブジェクトを取り出す。
    
    If objNAMEm.Length <> 3 Then  'mが３つ見つからなかったら。
        MsgBox "開催地の選択が見つかりません name=m システム管理者に連絡してください"
        Exit Sub
    End If
    
    '３番目のmが 開催地なので 3-1 の ２ 固定値を使う。
    Debug.Print "objNAMEm(2).Options.Length " & objNAMEm(2).Options.Length
    nMAXJYOMEI = objNAMEm(2).Options.Length  '.Options.Length で オプションの数を保存する。
    
    For n = 0 To nMAXJYOMEI - 1 'カウントが０なのでMAX-１のループ
        strJYOMEI(n) = objNAMEm(2).Options(n).Innertext 'OPTIONのn番目の文字を代入
        Debug.Print "objNAMEm(2).Options(" & n & ").Innertext = " & objNAMEm(2).Options(n).Innertext
    Next n
    
  '書き込み先を準備する
    '新規のブックを追加する
    Workbooks.Add  '新規ブックを追加
    
  '各開催地・レース場分、オッズの取り込み処理を繰り返す
    For n = 0 To nMAXJYOMEI - 1  'カウントが０なのでMAX-１のループ
        Call jMENU_Click '情報メニューを起動する(クリックする)
        Call bGET_TAN_RACEJYO(n)  'レース場をn番目に切り替える

        Sheets.Add          'シートを新規追加する
        ActiveSheet.Name = strJYOMEI(n)  'シート名を開催地名・開催場所にする
        Range("A1").Value = "'" & strJYOMEI(n)  'セルA1に開催地をセットする。
        Range("A1").Font.Size = 20       'フォントのサイズを２０にする
        
        Call bGET_TAN_1R_12R     'オッズのボタンを押して、1R-12Rの単勝オッズを取り込む。
    Next n
    
End Sub

'情報メニューの起動
Private Sub jMENU_Click()  '情報メニューをクリックする。

    '情報メニューを起動する(クリックする)
    Dim n       As Integer 'ループのカウンター
    Dim nLinkNo As Integer '見つけたメニューの番号
    
    nLinkNo = -1   'エラーの-1で初期化する
    For n = 0 To Me.WebBrowser2.Document.Links.Length - 1 'リンクオブジェクトから探る
        'タイトルが情報メニューのリンクを探す
        If Me.WebBrowser2.Document.Links(n).Title = "情報メニュー" Then
            nLinkNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n
    
    'エラーの判断
    If nLinkNo = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox "情報メニューが見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    '見つけたリンクを押す .Click
    Me.WebBrowser2.Document.Links(nLinkNo).Click  '単純に.Clickメソッドを使う
    DoEvents
    '↑次は、ここで起動した 情報メニューを捕まえないとなぁ。。。

    'WebBrowser1に切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。

End Sub

'レース場、開催地の選択
Private Sub bGET_TAN_RACEJYO(nJNO As Integer)  '上からn番目の数値を受け取り、単純に選択する。

    Dim n As Integer
    
    'INPUTタグ 決定のボタンを探す
    Dim tagINPUT As Object  'INPUTのタグを保存する
    Dim nInputNo As Integer '見つけたオブジェクトの場所
    Set tagINPUT = Me.WebBrowser1.Document.all.tags("INPUT") 'INPUTのタグを取り出す

    nInputNo = -1   'エラーの-1で初期化する
    For n = 0 To tagINPUT.Length - 1  'INPUTのタグを頭から探る
        If tagINPUT(n).Value = "決定" Then
            nInputNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n

    'エラーの判断
    If nInputNo = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox "決定 ボタンが見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    '上の階層、Formを探す。見つけたらobjFORMに代入する。
    Dim objFORM As Object
    Dim objOYA_TAG As Object    '親のオブジェクトを入れる
    Set objOYA_TAG = tagINPUT(nInputNo).parentElement '見つけたINPUTの親を代入
    While objOYA_TAG.tagname <> "FORM"  'タグの名前がFORMになるまで(FORM以外の間まわる)
        Set objOYA_TAG = objOYA_TAG.parentElement  'さらに、一つ上の親タグを代入
    Wend
    Set objFORM = objOYA_TAG   '見つけたオブジェクトを代入(そのまま、下で使ってもいいんだけど。)

    '↑で見つけたFORMを操作する。
    Dim objSELECT As Object    'SELECTのタグ

    
    Set objSELECT = objFORM.Item("m")  'Name=m Select を 代入
    
    objSELECT.Options(nJNO).Selected = True    '引数で受け取った 開催地・レースを選択する

    'Formを送信する(決定ボタン.Clickでもいいけど FORM.Submitにしました)
    objFORM.Submit    '単純に.Submitメソッドで実行

End Sub


'オッズのボタンを押し、単勝オッズに切り替え、データをシートに書き込む
Private Sub bGET_TAN_1R_12R()

    Dim n As Integer   'カウンター

    '表示完了後、INPUTタグ オッズのボタンを探す
    Dim tagINPUT As Object  'INPUTのタグを保存する
    Dim nInputNo As Integer '見つけたオブジェクトの場所
    Set tagINPUT = Me.WebBrowser1.Document.all.tags("INPUT") 'INPUTのタグを取り出す

    nInputNo = -1   'エラーの-1で初期化する
    For n = 0 To tagINPUT.Length - 1  'INPUTのタグを頭から探る
        If tagINPUT(n).Value = "オッズ" Then
            nInputNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n

    'エラーの判断
    If nInputNo = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox "オッズボタンが見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    '見つけた場所 nInputNoのINPUTを押す .Click
    tagINPUT(nInputNo).Click  '単純に.Clickメソッドを使う
    DoEvents
    '↑次は、ここで起動した オッズの表を操作する

    'WebBrowser1の切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。

    'SELECT タグから 単・複・枠連オッズ を 選択
    Dim tagSELECT As Object  'タグ保存用
    Set tagSELECT = Me.WebBrowser1.Document.all.tags("SELECT")  'SELECTのタグを抜き出す
    tagSELECT.Item("g").Value = "Ota01"  'アイテム g に Ota01 を セット、選択されている値を直接代入で変更
    
    '上の階層、Formを探して、.Submitする。
    Dim objOYA_TAG As Object    '親のオブジェクトを入れる
    Set objOYA_TAG = tagSELECT.Item("g").parentElement
    While objOYA_TAG.tagname <> "FORM"  'タグの名前がFORMになるまで(FORM以外の間まわる)
        Set objOYA_TAG = objOYA_TAG.parentElement  'さらに、一つ上の親タグを代入
    Wend
    objOYA_TAG.Submit   '上へ行き、見つけたフォームを.Submit 送信処理
    DoEvents
    
    'WebBrowser1の切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    DoEvents
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。

    '単勝の表を取り込む。
    '1R〜データが無くなるまで、処理を繰り返す
    
    Call bGET_TAN_sub_TABLE_COPY(2)  '単勝取り込み 1R
    
    Dim nRACE As Integer
    Dim Y     As Integer
    
    For nRACE = 2 To 12  '2R-12R
        Call bGET_TAN_RACE_SELECT(CStr(nRACE) & "R")    'レースの切り替え
        Call bGET_TAN_sub_TABLE_COPY(25 * (nRACE - 1) + 1) '単勝取り込み
    Next

    '列幅を調整する。
    Columns("A:B").Select     'AとB列の列幅を６に
    Selection.ColumnWidth = 6
    
    Columns("C:K").Select     'C〜K列を オート調整
    Columns("C:K").EntireColumn.AutoFit
    
    Range("A1").Select  'カーソルを先頭へ

End Sub

'レース番号を受け取り、切り替える。
Private Sub bGET_TAN_RACE_SELECT(strRACE As String)

    Dim n As Integer

    'OPTION タグからレースを 選択
    Dim tagOPTION As Object  'タグ保存用
    Dim nOPTION   As Integer '見つけたOPTIONタグを保存する変数。

    Set tagOPTION = Me.WebBrowser1.Document.all.tags("OPTION")  'OPTIONのタグを抜き出す
    
    nOPTION = -1   'エラーの-1で初期化する
    For n = 0 To tagOPTION.Length - 1  'OPTIONのタグを頭から探る
        If tagOPTION(n).Innertext = strRACE Then  'レース番号を探す、OPTIONのテキストで比較する
            nOPTION = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n

    'エラーの判断
    If nOPTION = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox strRACE & "レースが見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    'OPTIONをセレクト、選択する。
    tagOPTION(nOPTION).Selected = True   '見つけたオブション(レース)を選択状態にする
    
    '上の階層、Formを探して、.Submitする。
    Dim objOYA_TAG As Object    '親のオブジェクトを入れる
    Set objOYA_TAG = tagOPTION(nOPTION).parentElement '見つけたOPTIONの親を代入
    While objOYA_TAG.tagname <> "FORM"  'タグの名前がFORMになるまで(FORM以外の間まわる)
        Set objOYA_TAG = objOYA_TAG.parentElement  'さらに、一つ上の親タグを代入
    Wend
    objOYA_TAG.Submit   '上へ行き、見つけたフォームを.Submit 送信処理
    DoEvents

    'WebBrowser1の切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    DoEvents
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。

End Sub

'Y行目をもらって、オッズの表をセットする。
Private Sub bGET_TAN_sub_TABLE_COPY(nYLINE As Integer)
    'テーブル取り出しのテスト
    Dim n As Integer

    'WebBrowser1の切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    DoEvents
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。

    '表示完了後、THタグ 馬名を探す
    Dim tagTH As Object  'THのタグを保存する
    Dim nTHNo As Integer '見つけたオブジェクトの場所
    Set tagTH = Me.WebBrowser1.Document.all.tags("TH") 'THのタグを取り出す

    nTHNo = -1   'エラーの-1で初期化する
    For n = 0 To tagTH.Length - 1  'THのタグを頭から探る
        If tagTH(n).Innertext = "馬名" Then
            nTHNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n

    'エラーの判断
    If nTHNo = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox "馬名の表が見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    '見つけた場所 nTHNoから上のTABLEオブジェクトを探す
    Dim objOYA_TAG As Object    '親のオブジェクトを入れる
    Set objOYA_TAG = tagTH(nTHNo).parentElement  '見つけたTH馬名 その上.parentElementを代入
    While objOYA_TAG.tagname <> "TABLE"  'タグの名前がTABLEになるまで(TABLE以外の間まわる)
        Set objOYA_TAG = objOYA_TAG.parentElement  'さらに、一つ上の親タグを代入
    Wend
    '↑必ずTHの上にTABLEがあると仮定して、エラー処理はしてないけど・・・
    
    'テーブルが見つかったので、コピーする。
    Dim r As Object
    Set r = Me.WebBrowser1.Document.body.createControlRange
    r.Add objOYA_TAG '上で見つけたテーブルを指定する。
    r.Select                    'セレクト 選択
    Me.WebBrowser1.ExecWB 12, 0          'コマンド発行 OLECMDID_COPY = 12 コピー
    Set r = Nothing  'Rは用済み

    '形式を選択して貼り付け HTML貼り付けのテスト
    Range("A" & CStr(nYLINE + 3)).Select
    ActiveSheet.PasteSpecial Format:="HTML"
    
    
    '単勝（人気順）
    
    Set tagTH = Me.WebBrowser1.Document.all.tags("TH") 'THのタグを取り出す

    nTHNo = -1   'エラーの-1で初期化する
    For n = 0 To tagTH.Length - 1  'THのタグを頭から探る
        If tagTH(n).Innertext = "単勝（人気順）" Then
            nTHNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n

    'エラーの判断
    If nTHNo = -1 Then   '-1のまま、見つからなかったら、エラーにする。
        MsgBox "単勝（人気順）の表が見つかりません、システム管理者に連絡してください"
        Exit Sub  '関数を抜ける
    End If
    
    '見つけた場所 nTHNoから上のTABLEオブジェクトを探す
    Set objOYA_TAG = tagTH(nTHNo).parentElement  '見つけたTH馬名 その上.parentElementを代入
    While objOYA_TAG.tagname <> "TABLE"  'タグの名前がTABLEになるまで(TABLE以外の間まわる)
        Set objOYA_TAG = objOYA_TAG.parentElement  'さらに、一つ上の親タグを代入
    Wend
    '↑必ずTHの上にTABLEがあると仮定して、エラー処理はしてないけど・・・
    
    'テーブルが見つかったので、コピーする。
    Set r = Me.WebBrowser1.Document.body.createControlRange
    r.Add objOYA_TAG '上で見つけたテーブルを指定する。
    r.Select                    'セレクト 選択
    Me.WebBrowser1.ExecWB 12, 0          'コマンド発行 OLECMDID_COPY = 12 コピー
    Set r = Nothing  'Rは用済み

    '形式を選択して貼り付け HTML貼り付けのテスト
    Range("I" & CStr(nYLINE + 2)).Select
    ActiveSheet.PasteSpecial Format:="HTML"

    'DIV class="bold1" レース名 class="bold2" G3-G1などのレース名 をセットする。
    Dim tagDIV As Object
    
    Set tagDIV = Me.WebBrowser1.Document.all.tags("DIV") 'DIVのタグを取り出す

    For n = 0 To tagDIV.Length - 1  'DIVのタグを頭から探る class="bold1"を探す
        If InStr(tagDIV(n).outerHTML, "bold1") > 0 Then 'class="bold1"を探す
            Range("A" & CStr(nYLINE + 0)).Value = tagDIV(n).Innertext  '見つけた文字をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n
    
    For n = 0 To tagDIV.Length - 1  'DIVのタグを頭から探る class="bold2"を探す
        If InStr(tagDIV(n).outerHTML, "bold2") > 0 Then 'class="bold2"を探す
            Range("A" & CStr(nYLINE + 1)).Value = tagDIV(n).Innertext  '見つけた文字をセットする。
            Exit For  '見つけたのでループを抜ける。
        End If
    Next n
    

End Sub

残念・時間切れ・・・

終わりの挨拶

前回までの記事は→[2009-04-05 表の取り込み]を見てください。
最新情報と作成履歴は→[更新履歴と最新を表示]
実行可能なサンプルファイルは:[IE_UMA_0418.zip]←サンプルの IE_UMA_0418.xls です。

ページフッター リンクや広告、質問送信など

三流解説を読んでいただき、どうもです。ここから下は、三流君宛のメッセージ送信や 三流君のホームページの紹介・案内です
目的の情報が見つかったか？少々心配しつつ、、、※質問や感想は、気軽に送ってくださいね。

質問や要望など メッセージを送る(三流君に連絡する)

三流プログラマーのKen3 が 皆さんの質問にお答えします
と カッコつけて言っても、実力不足ですべての質問に回答することはできないのが現実なのですが、できる範囲で 三流的な逃げ手 や 解決方法 を探します(回答します)。

急ぎで連絡がほしい、そんな時は:[三流君連絡先]に連絡してください。

IE関係、VBA関係 の 三流君のホームページの紹介・案内