- 日時： 2012/01/28 13:47
- 名前： VBレスキュー(花ちゃん)
- ***********************************************************************************
* カテゴリー：[インターネット][][] *
* キーワード：ログイン,自動的に,検索,メール,IE,ボタンをクリック,テキスト入力 *
***********************************************************************************
-----------------------------------------------------------------------------------
投 稿 日：2012/01/12 14:30
投 稿 者：VBレスキュー(花ちゃん)
SampleNo：583 2012.01.12 ① 2012.01.12
タイトル：WebBrowserを使ってのHTMファイル内の全ての要素を調査
動作確認：Windows Vista / Windows 7 / VB6.0(SP6) IE 9.0 で確認
-----------------------------------------------------------------------------------
某掲示板での質問に答えるべく作ったものを VB6.0 用に書き換えたものです。
エラー処理やデザイン・コードも簡略化しておりますので、各自目的や好みに合わせ作り
直して下さい。
VBA で使用する場合は、コントロール名を変更するだけで使用できます。(Excel2007/2010で確認)
※ 使用コントロール及び貼り付け位置等は下図の実行結果図を参考にお好みで。
尚、便宜上 TextBox に表示しておりますが、Webページ上の表示データーが多いと全部取得
できませんので、RichTextBox に変更するか、個別にタグを指定して取得して下さい。
Option Explicit
Private Sub Command1_Click()
'指定のサイトを表示
' 該当のサイトが表示されてから実行してくださ｡
WebBrowser1.Navigate Text1.Text
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
End Sub
Private Sub Command2_Click()
'全ての要素を取得（その１）
On Error Resume Next '中には該当する項目がなくエラーが発生する場合があるので
Text2.Text = ""
Dim i As Long, Element As Object, k As Long
With WebBrowser1.Document
For Each Element In .All 'すべての要素内を調べる場合 .Forms(k).All
'For Each Element In .Forms(k).All.tags("input") 'INPUT タグだけを調べる場合
'Debug.Print Element.tagName
If Element.tagName = "IFRAME" Or Element.tagName = "shape" Then
'実行時エラーが発生するので無視する(上記以外にもあれば追加して下さい)
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
"★ 必要な場合別途調査して下さい。★" & vbCrLf
ElseIf Element.tagName = "OPTION" Or Element.tagName = "A" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Text=" & Element.innerText & vbCrLf
ElseIf Element.getAttribute("Type") = "image" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Alt =" & Element.alt & vbCrLf
Else
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Value =" & Element.getAttribute("value") & vbCrLf
End If
i = i + 1
Next
End With
End Sub
Private Sub Command3_Click()
'全ての要素を取得（その２）Form 別に取得
On Error Resume Next '中には該当する項目がなくエラーが発生する場合があるので
Text2.Text = ""
Dim i As Long, Element As Object, k As Long
'こちらは、form 別に取得（Formに属していない要素もあるので注意）
For k = 0 To WebBrowser1.Document.Forms.length - 1
With WebBrowser1.Document
For Each Element In .Forms(k).All 'すべての要素内を調べる場合
'For Each Element In .Forms(k).All.tags("input") 'INPUT タグだけを調べる場合
If Element.tagName = "IFRAME" Or Element.tagName = "shape" Then
'実行時エラーが発生するので無視する(上記以外にもあれば追加して下さい)
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
"★ 必要な場合別途調査して下さい。★" & vbCrLf
ElseIf Element.tagName = "OPTION" Or Element.tagName = "A" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("FormNo.=" & k & " ", 11) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Text=" & Element.innerText & vbCrLf
ElseIf Element.getAttribute("Type") = "image" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("FormNo.=" & k & " ", 11) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Alt =" & Element.alt & vbCrLf
Else
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("FormNo.=" & k & " ", 11) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Value =" & Element.getAttribute("value") & vbCrLf
End If
i = i + 1
Next
End With
Next k
End Sub
Private Sub Command4_Click()
'指定の要素だけを取得
On Error Resume Next '中には該当する項目がなくエラーが発生する場合があるので
Text2.Text = ""
Dim i As Long, Element As Object, k As Long
With WebBrowser1.Document
For Each Element In .All.tags(Text3.Text)
If Element.tagName = "IFRAME" Or Element.tagName = "shape" Then
'実行時エラーが発生するので無視する(上記以外にもあれば追加して下さい)
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
"★ 必要な場合別途調査して下さい。★" & vbCrLf
ElseIf Element.tagName = "OPTION" Or Element.tagName = "A" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Text=" & Element.innerText & vbCrLf
ElseIf Element.getAttribute("Type") = "image" Then
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Alt =" & Element.alt & vbCrLf
Else
Text2.Text = Text2.Text & Left$("No.=" & Str(i) & " ", 10) & _
Left$("要素名=" & Element.tagName & " ", 14) & _
Left$("Type=" & Element.getAttribute("Type") & Space$(20), 24) & _
Left$("Name=" & Element.getAttribute("NAME") & Space$(20), 24) & _
Left$("ID=" & Element.getAttribute("ID") & Space$(24), 26) & "Value =" & Element.getAttribute("value") & vbCrLf
End If
i = i + 1
Next
End With
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
'該当のサイト以外は除外
If TypeName(pDisp) <> "WebBrowser" Or URL <> Text1.Text Then
Exit Sub
End If
'Do While Obj.Document.ReadyState <> "complete"
' DoEvents
'Loop
'上記のような待機処理で表示待ちをしないで下さい。
'表示されたので各ボタンを使用可能に
Command2.Enabled = True
Command3.Enabled = True
Command4.Enabled = True
End Sub
実行結果図(画像をクリックすると元のサイズで見る事ができます。)
|
WebBrowserを使ってのHTMファイル内の全ての要素を調査(VB6.0)