tagCANDY CGI VBレスキュー(花ちゃん) - VBレスキュー(花ちゃん)の投稿サンプル用掲示板 - Visual Basic 6.0 VB2005 VB2010
VB2005用トップページへVBレスキュー(花ちゃん)のトップページVB6.0用のトップページ
VBレスキュー(花ちゃん)の投稿サンプル用掲示板
     サンプル投稿用掲示板  VB2005 〜 用トップページ  VB6.0 用 トップページ
WebBrowserを使ってのHTMファイル内の全ての要素を調査(VB6.0) ( No.0 )  [親スレッドへ]
日時: 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()
'全ての要素を取得(その1)
   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()
'全ての要素を取得(その2)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


実行結果図(画像をクリックすると元のサイズで見る事ができます。)



 [スレッド一覧へ] [親スレッドへ]