[トップページ] / [サンプル一覧へ]

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

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

表の取り込み

今回は、表の取り込みをメインに実行してみます。

表を取り込む 試作・テスト実行

やっと、表の取り込みです。
<TH>馬名</TH>
を探し、テーブルを確定させます。

で、また、手前味噌サンプルの
document.body.createControlRange を使い、テーブルを指定する
http://www.ken3.org/cgi-bin/group/vba_ie.asp#createControlRange
を使い、テーブルを選択して、コピーします。

そのコピーしたテーブルを貼り付けます。
そんな感じの処理を作ってみます。


Private Sub CommandButton1_Click()
    Debug.Print Me.WebBrowser1.Document.URL
    Debug.Print Me.WebBrowser1.Document.Title
    
    'テーブル取り出しのテスト
    Dim n As Integer
    
    '表示完了後、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 コピー

    'テスト用に新規のブックを追加する
    Workbooks.Add  '新規ブックを追加
    
    '形式を選択して貼り付け HTML貼り付けのテスト
    Sheets.Add          'テスト用のシートを新規追加する
    ActiveSheet.Name = "HTML形式で貼り付け"  'シートに名前を付ける
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="HTML"
    
    '形式を選択して貼り付け Unicode テキスト貼り付けのテスト
    Sheets.Add          'テスト用のシートを新規追加する
    ActiveSheet.Name = "FormatUnicode テキスト"  'シートに名前を付ける
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="Unicode テキスト"

    '形式を選択して貼り付け テキスト貼り付けのテスト
    Sheets.Add          'テスト用のシートを新規追加する
    ActiveSheet.Name = "Formatテキスト"  'シートに名前を付ける
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="テキスト"
    
End Sub


まぁ、ポイントは、
    Set tagTH = Me.WebBrowser1.Document.all.tags("TH") 'THのタグを取り出す
で、いつものようにTHを取り出して、
    For n = 0 To tagTH.Length - 1  'THのタグを頭から探る
        If tagTH(n).InnerText = "馬名" Then
            nTHNo = n   '見つけた番号をセットする。
            Exit For  '見つけたのでループを抜ける。
↑、テキスト の 馬名を探します。

探し終わったら、そのテーブルを見つけるために、
.parentElement を 使って、親のテーブルまでたどり着きます。

    '見つけた場所 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 コピー↑、テーブル全体をコピーします。

コピーしたら、貼り付けって感じで、あとは、
    '形式を選択して貼り付け HTML貼り付けのテスト
    Sheets.Add          'テスト用のシートを新規追加する
    ActiveSheet.Name = "HTML形式で貼り付け"  'シートに名前を付ける
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="HTML"
こんな感じで貼り付けました。

さてと、あとは、１レースから最終レースまで繰り返して 貼り付けますか。
03/29 THタグから 馬名 を探し、そのテーブルをコピー貼り付けする : http://www.youtube.com/watch?v=uZV6V27LVak

単勝（人気順） を探し、データをセットする

同様に、
<TH>単勝（人気順）</TH>
を探し 表をコピーして、貼り付けます。

単純に探す文字を "単勝（人気順）"としただけですが、


Private Sub CommandButton1_Click()
    Debug.Print Me.WebBrowser1.Document.URL
    Debug.Print Me.WebBrowser1.Document.Title
    
    'テーブル取り出しのテスト
    Dim n As Integer
    
    '表示完了後、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は用済み

    'テスト用に新規のブックを追加する
    Workbooks.Add  '新規ブックを追加
    
    '形式を選択して貼り付け HTML貼り付けのテスト
    Sheets.Add          'テスト用のシートを新規追加する
    ActiveSheet.Name = "HTML形式で貼り付け"  'シートに名前を付ける
    Range("A1").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("I1").Select
    ActiveSheet.PasteSpecial Format:="HTML"

End Sub


↑、こんな感じで、単体のテストじゃないけど、取り出しができました。
04/05 THタグから 単勝（人気順）を探し貼り付け : http://www.youtube.com/watch?v=vyafD9l1iDI

2R を 選択する OPTIONタグから レースを探し .Selected = True 

単勝の表、オッズがとれたので、
あとは、繰り返し処理なんだけど、
その前に、調べ事が。

流れとしては、
  1Rの表を表示
  1Rのオッズをシートに取り込む。
  2Rの表を表示 ←※１
  2Rのオッズをシートに取り込む。
  3Rの表を表示
  3Rのオッズをシートに取り込む。
      ・
　　　・
      ・
って、感じなんだろうけど。
オッズをシートに取り込む は できたので(つなげてないけど、)
※１の2Rの切り替えを先にテストしてみます。


Private Sub CommandButton1_Click()
    Debug.Print Me.WebBrowser1.Document.URL
    Debug.Print Me.WebBrowser1.Document.Title
    
    Dim n As Integer
    Dim strRACE As String
    strRACE = InputBox("どのレース？に切り替える？", "TEST", "2R")
    
    '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 送信処理
    
    
    'Stop   'とめる
End Sub


↑ポイントは
Set tagOPTION = Me.WebBrowser1.Document.all.tags("OPTION")
で、OPTIONのタグを抜き出し
    For n = 0 To tagOPTION.Length - 1  'OPTIONのタグを頭から探る
        If tagOPTION(n).InnerText = strRACE Then
でレース番号を探します(OPTIONのテキストで比較する)

無事見つけたら、
tagOPTION(nOPTION).Selected = True
で、オブションを選択状態にする

あとは、親のタグがFORMになるまで上に行き、
.Submitで送信、無事レースが切り替わります。

こんな感じです。
04/05 OPTIONタグから レースを探し .Selected = True : http://www.youtube.com/watch?v=TXWJOITWIe8

1R〜12Rまで 連続で 単勝オッズを取り込む

やっと、単体テスト？も終わり、結合してみたいと思います。


Option Explicit

Private Sub bGET_TAN_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メソッドを使う
    '↑次は、ここで起動した 情報メニューを捕まえないとなぁ。。。

    'WebBrowser1に切り替わり、表示を待つ
    While Me.WebBrowser1.Busy Or Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    
    '切り替わりが速いと動画がつまらないので、1秒待つ(↑上の処理でOKなので、これは必要ないです。)
    Application.Wait Time:=Now + TimeValue("00:00:01")  '動画作りで切り替わりを記録したいので使った
    '↑通常は、使いません。
    
    '表示完了後、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〜データが無くなるまで、処理を繰り返す
    
    '新規のブックを追加する
    Workbooks.Add  '新規ブックを追加
    Sheets.Add          'シートを新規追加する
    ActiveSheet.Name = "単勝オッズ"  'シートに名前を付ける
    
    Call bGET_TAN_sub_TABLE_COPY(1)  '単勝取り込み 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)) '単勝取り込み
    Next
    
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 + 1)).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)).Select
    ActiveSheet.PasteSpecial Format:="HTML"
    

End Sub


↑こんな感じで、それっぽく動きました・・・
※なんて、言ってますが、かなり苦労しました。

↓いつもの作成をミスった動画・・・みて笑ってください。
04/05 1R-12Rまで連続して 単勝オッズを取り込む : http://www.youtube.com/watch?v=GBoQBtcMPW8

レース場を切り替える、開催地の切り替え

なんとか、単勝オッズを1Rから連続で取り込めたので、
レース名など、細かい情報は置いておき、(なんだよ)
次は、開催地の切り替え、そんな処理を探ってみます。

ソースを見ると、

<FORM action="********" method="post">
<INPUT type="hidden" name="g" value="Mnu01">
<INPUT type="hidden" name="s" value="0000000">
<INPUT type="hidden" name="j" value="3091200000">
<TD><SELECT size="3" name="m">
<OPTION value="60936">2009年  3回 中山  6日 （当日売）
<OPTION value="90926">2009年  2回 阪神  6日 （当日売）
<OPTION value="30912" selected>2009年  1回 福島  2日 （当日売）
</SELECT></TD>
　・
　・
　・
<INPUT type="submit" value="決定"></TD></FORM>

となっているので、
まず、<INPUT type="submit" value="決定">
を探し、FORMを見つける。
見つけたFORMの中の、
<SELECT size="3" name="m">
の OPTION を 選択する。そんな感じで作ってみたいと思います。


Private Sub CommandButton1_Click()  'テストで使う
    Debug.Print Me.WebBrowser1.Document.URL
    Debug.Print Me.WebBrowser1.Document.Title
    
    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(1).Selected = True  'テストで上から2番目選択

    Debug.Print "objSELECT.Options.Length " & objSELECT.Options.Length
    
    Debug.Print "objSELECT.Options(0).Innertext " & objSELECT.Options(0).Innertext
    Debug.Print "objSELECT.Options(1).Innertext " & objSELECT.Options(1).Innertext
    Debug.Print "objSELECT.Options(2).Innertext " & objSELECT.Options(2).Innertext

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

End Sub


ポイントは、
<INPUT type="submit" value="決定">
を探し、
    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
みたいに、
.tags("INPUT") で取り出し、
If tagINPUT(n).Value = "****" Then
で判断しました。

FORMを見つけるには、
    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
↑決定ボタンから.parentElementで上・上・上の親オブジェクトを探し、
FORMまでたどり着きます。

次は、見つけたFORMの中の、
<SELECT size="3" name="m">
の操作、 OPTION を 選択なので、
Nameが付いていたので利用して、
    Set objSELECT = objFORM.Item("m")  'Name=m Select を 代入
.Item("m") を使って、簡単に指定できました。
あとは、OPTIONの選択なので、
    objSELECT.Options(1).Selected = True  'テストで上から2番目選択
.Optionsで、SELECT中のOPTIONタグに比較的簡単にたどり着けました。
04/12 レース場を切り替える、開催地の切り替え IE操作 単勝表取込み : http://www.youtube.com/watch?v=ZPRcprX-i5Q

残念・時間切れ・・・

ここから、来週の土日に作成する。
またかよ。。いったい、いつになったら、完成するんだい・・・

終わりの挨拶

いいところで、終わってしまった。。。
続きは、→[2009-04-18 結合テスト]
最新情報と作成履歴は→[更新履歴と最新を表示]
実行可能なサンプルファイルは:[IE_UMA_0405.zip]←サンプルの IE_UMA_0405.xls です。

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

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

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

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

感想や質問・要望・苦情など 三流君へメッセージを送る。
時間的余裕のある要望・質問・苦情の場合は、下記のフォームからメッセージを送ることができます。
あなたのお名前（ニックネーム）:さん
返信は？: 不用(HP更新を待つ) , E-mail→ アドレス:に返事をもらいたい



(感想や質問・要望 メッセージはHPで記事に載せることがあります。)

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

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

[IE操作 三流解説のトップページへ 戻る] / [IE操作の三流サンプル一覧へ 戻る]

[三流君 VBAでWebBrowser IEを操作する] / [三流君 VBAで楽しくプログラミング] / [AB型の変わり者 三流プログラマー Ken3 三流君Top]

F1でヘルプを見たり、デバック時にDebug.Print使ったり、イミディエイト ウインドウで簡単な確認したり。
なれると当たり前に操作している方法が↓かなぁ。
[F1ヘルプ マクロ記録ほか]・・・基本のF1を押してヘルプを見る方法など
[実行時エラー、デバッグモード]・・・デバッグの流れを簡単に（ハマった時はツライけど）
[イミディエイト ウインドウ と Debug.Print]・・・プログラム作成時に便利なイミディエイト ウインドウ
[VBA ウォッチ式とSTOPを使ってみた]・・・STOPで止め、ウォッチ式でオブジェクトの中身を確認する方法など
[参照設定のお話]・・・設定すると便利な(設定しないと使えない)、参照設定のお話

項目別に↓にプログラマーの本音？それとも建て前？的な記事をまとめました。お探しのジャンルを選択してください。
[プログラムは心？ spirit]・・・プログラマー 心・気質・魂
[学ぶ study]・・・学習、技術の取得
[仕様書 doc]・・・仕様書・設計書関係の話

項目別に↓に人気の記事をまとめてみました。お探しのジャンルを選択してください。
[VBAでIE ウェブブラウザーを操作]・・・VBAでIE,WebBrowserを操作する サンプルです
[MSアクセス から エクセル を呼ぶ Excel.Application]・・・AccessからExcelを操作したりデータの書き出しなどです
[アウトルック メールの操作 Outlook.Application]・・・VBAからOutlookを使い、メール関係を処理するサンプルです
↑上記３つみたいなCreateObjectで他のアプリケーションを操作するサンプルが人気です。

Excel関係:
[エクセル ユーザーフォームを操作する]・・・エクセルでユーザーフォームを作成して入力などを行ってます
[エクセルからアクセスを操作する]・・・ExcelからAccessのマクロを起動してみました、
[エクセル関係 関数、その他]・・・その他Excel関係です

Access関係:
[アクセス ユーザーフォーム/サブフォーム 操作]・・・アクセスでフォームを使ったサンプルです
[アクセス レポート操作]・・・レポートを操作してみました
[アクセス クエリーやその他関数]・・・あまりまとまってませんが、スポット的な単体関数の解説です

その他：VBAの共通関数やテキストファイルの操作など
[テキストファイルの操作(Open,Close,Print,Input)]・・・普通のテキストファイルを使ったサンプルです

Blog:[三流君の作業日記]/ [objIEを使用したサンプルコードを見る]/ 広告-[通販人気商品の足跡]


[トップページへ 戻る] / [サンプル一覧へ 戻る]