03/29 THタグから 馬名 を探し、そのテーブルをコピー貼り付けする

03/29 THタグから 馬名 を探し、そのテーブルをコピー貼り付けする
http://www.youtube.com/watch?v=uZV6V27LVak

<object width="500" height="405"><param name="movie" value="http://www.youtube.com/v/uZV6V27LVak&hl=ja&fs=1&color1=0xcc2550&color2=0xe87a9f&border=1"></param><param name="allowFullScreen" value="true"></param><param name="allowscriptaccess" value="always"></param><embed src="http://www.youtube.com/v/uZV6V27LVak&hl=ja&fs=1&color1=0xcc2550&color2=0xe87a9f&border=1" type="application/x-shockwave-flash" allowscriptaccess="always" allowfullscreen="true" width="500" height="405"></embed></object>

表を取り込む 試作・テスト実行
やっと、表の取り込みです。
<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"
こんな感じで貼り付けました。

さてと、あとは、１レースから最終レースまで繰り返して 貼り付けますか。