やっと、表の取り込みです。
を探し、テーブルを確定させます。
で、また、手前味噌サンプルの
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
