IE 情報取得①
ダウンロード
Option Explicit
'URLを指定してIEを取得する
Function UrlIE(UrlTarget As String) As Object
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate UrlTarget
Do While ie.Busy = True Or ie.readyState <> 4
DoEvents
Loop
Set UrlIE = ie
End Function
'要素を全て取得（確認用の要素一覧）
Sub MakeIchiran()
Dim objie As Object
Set objie = UrlIE("https://www.yahoo.co.jp/")
Call Ichiran_Make(objie)
MsgBox "一覧を作成しました"
End Sub
Sub Ichiran_Make(objie As Object)
Dim el As Object
Dim n As Long
Sheets("一覧").Select
Cells.ClearContents
'タイトル入力
Cells(1, 1) = "No."
Cells(1, 2) = "TypeName"
Cells(1, 3) = "tagName"
Cells(1, 4) = "outerHTML"
Cells(1, 5) = "innerHTML"
Cells(1, 6) = "outerText"
'幅指定
Cells(1, 1).ColumnWidth = 5.63
Cells(1, 2).ColumnWidth = 9.63
Cells(1, 3).ColumnWidth = 4.75
Cells(1, 4).ColumnWidth = 12.38
Cells(1, 5).ColumnWidth = 12.38
Cells(1, 6).ColumnWidth = 12.38
For Each el In objie.document.all
n = n + 1
Cells(n + 1, 1) = n
Cells(n + 1, 2) = "'" & TypeName(el) 'TypeNameでオブジェクトのタイプを表示
Cells(n + 1, 3) = "'" & el.tagName 'タグの名前
Cells(n + 1, 4) = "'" & el.outerHTML
Cells(n + 1, 5) = "'" & el.innerHTML
Cells(n + 1, 6) = "'" & el.outerText
Next el
End Sub
IE 情報取得②
Sub IElinkall()
Application.ScreenUpdating = False
'*****↓ここまでは以前と一緒***************************************************
'IEの起動
Dim objie As Object
Set objie = GetObject("", "InternetExplorer.Application")
objie.Visible = True
objie.navigate "https://www.google.com/?hl=ja" ' このURLを任意に変更
' ページの表示完了待ち｡
While objie.readyState <> 4 Or objie.Busy = True
DoEvents
Wend
'*****↑ここまでは以前と一緒***************************************************
'****今日はここから↓***************************************************
On Error Resume Next '値がないとエラーが出るので、エラー回避用
I = 1 '開始行を指定
J = objie.document.all.Length '要素の数を知る
Cells(I, 1).Value = "uniqueID"
Cells(I, 2).Value = "tagname"
Cells(I, 3).Value = "Type"
Cells(I, 4).Value = "NAME"
Cells(I, 5).Value = "ID"
Cells(I, 6).Value = "className"
Cells(I, 7).Value = "TABINDEX"
Cells(I, 8).Value = "Vakue"
Cells(I, 9).Value = "checked"
Cells(I, 10).Value = "親のtagname"
Cells(I, 11).Value = "innertext"
Cells(I, 12).Value = "outertext"
Cells(I, 13).Value = "outherhtml"
Cells(I, 14).Value = "innerhtml"
Cells(I, 15).Value = "リンク先"
Dim A As Object
For Each A In objie.document.getElementsByTagName("A")
Cells(I + 1, 1) = A.uniqueID 'uniqueID
Cells(I + 1, 2) = A.tagName '親のTAG
Cells(I + 1, 3) = A.Type 'タイプ ※selectボックスは”select-one”と取得
Cells(I + 1, 4) = A.Name '名前
Cells(I + 1, 5) = A.ID 'ID
Cells(I + 1, 6) = A.className 'クラス名
Cells(I + 1, 7) = A.TabIndex 'フォーカス順序 (Tabでの移動順)
Cells(I + 1, 8) = A.Value '値
Cells(I + 1, 9) = A.Checked 'チェック状態 (True = チェック有り､false = チェック無し)
'checkboxやradioボタンから取得します
Cells(I + 1, 10) = A.parentElement.tagName '親のTAG
If Len(A.innerHTML) > 50 Then
Cells(I + 1, 11) = Left(A.innertext, 10) & " ~~~ " & Right(A.innertext, 10)
Cells(I + 1, 12) = Left(A.outerText, 10) & " ~~~ " & Right(A.outerrext, 10)
Cells(I + 1, 13) = Left(A.outerHTML, 10) & " ~~~ " & Right(A.outerHTML, 10)
Cells(I + 1, 14) = Left(A.innerHTML, 10) & " ~~~ " & Right(A.innerHTML, 10)
Else
Cells(I + 1, 11) = A.innertext
Cells(I + 1, 12) = A.outerText
Cells(I + 1, 13) = A.outerHTML
Cells(I + 1, 14) = A.innerHTML
End If
Cells(I + 1, 15) = A.href
I = I + 1
'ステータスバーに進捗を表示
Application.StatusBar = I & "/" & J
Next
On Error GoTo 0
Cells.WrapText = False
Application.ScreenUpdating = True
Application.StatusBar = False
Range(Cells(1, 1), Cells(1, 13)).EntireColumn.ColumnWidth = 1
Range(Cells(1, 14), Cells(1, 15)).EntireColumn.AutoFit
Range(Cells(1, 15), Cells(1, 15)).EntireColumn.Interior.ColorIndex = 6
End Sub
IE 情報取得③
Sub IEoutput2()
Application.ScreenUpdating = False
'*****↓ここまでは以前と一緒***************************************************
'IEの起動
Dim objIE As Object
Set objIE = GetObject("", "InternetExplorer.Application")
objIE.Visible = True
objIE.Navigate "https://www.yahoo.co.jp/" ' このURLを任意に変更
' ページの表示完了待ち｡
While objIE.ReadyState <> 4 Or objIE.Busy = True
DoEvents
Wend
'*****↑ここまでは以前と一緒***************************************************
'****今日はここから↓***************************************************
On Error Resume Next '値がないとエラーが出るので、エラー回避用
i = 1 '開始行を指定
J = objIE.document.all.Length '要素の数を知る
Cells(i, 1).Value = "uniqueID"
Cells(i, 2).Value = "tagname"
Cells(i, 3).Value = "Type"
Cells(i, 4).Value = "NAME"
Cells(i, 5).Value = "ID"
Cells(i, 6).Value = "className"
Cells(i, 7).Value = "TABINDEX"
Cells(i, 8).Value = "Vakue"
Cells(i, 9).Value = "checked"
Cells(i, 10).Value = "親のtagname"
Cells(i, 11).Value = "innertext"
Cells(i, 12).Value = "outertext"
Cells(i, 13).Value = "outherhtml"
Cells(i, 14).Value = "innerhtml"
Dim A As Object
For Each A In objIE.document.getElementsByTagName("*")
Cells(i + 1, 1) = A.uniqueID 'uniqueID
Cells(i + 1, 2) = A.TAGNAME '親のTAG
Cells(i + 1, 3) = A.Type 'タイプ ※selectボックスは”select-one”と取得
Cells(i + 1, 4) = A.Name '名前
Cells(i + 1, 5) = A.ID 'ID
Cells(i + 1, 6) = A.className 'クラス名
Cells(i + 1, 7) = A.TabIndex 'フォーカス順序 (Tabでの移動順)
Cells(i + 1, 8) = A.Value '値
Cells(i + 1, 9) = A.Checked 'チェック状態 (True = チェック有り､false = チェック無し)
'checkboxやradioボタンから取得します
Cells(i + 1, 10) = A.parentElement.TAGNAME '親のTAG
If Len(A.innerHTML) > 50 Then
Cells(i + 1, 11) = Left(A.innertext, 10) & " ~~~ " & Right(A.innertext, 10)
Cells(i + 1, 12) = Left(A.outertext, 10) & " ~~~ " & Right(A.outerrext, 10)
Cells(i + 1, 13) = Left(A.outerHTML, 10) & " ~~~ " & Right(A.outerHTML, 10)
Cells(i + 1, 14) = Left(A.innerHTML, 10) & " ~~~ " & Right(A.innerHTML, 10)
Else
Cells(i + 1, 11) = A.innertext
Cells(i + 1, 12) = A.outertext
Cells(i + 1, 13) = A.outerHTML
Cells(i + 1, 14) = A.innerHTML
End If
Dim C(20) As String
'階層を表示
For Z = 1 To 20
C(Z) = A.TAGNAME
If A.TAGNAME = "HTML" Then Exit For
Set A = A.parentElement
Next
For L = Z To 1 Step -1
Cells(i + 1, 30 + Z - L) = C(L)
Next
i = i + 1
'ステータスバーに進捗を表示
Application.StatusBar = i & "/" & J
Next
Cells.WrapText = False
Application.ScreenUpdating = True
Application.StatusBar = False
'表示を固定
Columns(1, 9).AutoFit
Cells(1, 2).EntireColumn.Interior.ColorIndex = 6
Cells(2, 3).Select
ActiveWindow.FreezePanes = True
objIE.document.getElementsByName("q")(0).Value = "テスト"
End Sub
IE 情報取得④
Option Explicit
'URLを指定してIEを取得する
Function UrlIE(UrlTarget As String) As Object
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate UrlTarget
Do While ie.Busy = True Or ie.readyState <> 4
DoEvents
Loop
Set UrlIE = ie
End Function
'要素を全て取得（確認用の要素一覧）
Sub MakeIchiran()
Dim objie As Object
Dim sFilePathRoot As String
Dim i As Integer
For i = 2 To Cells(Rows.Count, 5).End(xlUp).Row
'Set objie = UrlIE("https://www.smile-etc.jp/")
sFilePathRoot = ThisWorkbook.Sheets("HTML1").Cells(i, 5).Value & ThisWorkbook.Sheets("HTML1").Cells(i, 6).Value
Set objie = UrlIE(sFilePathRoot)
Call Ichiran_Make(objie)
Worksheets("一覧").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ThisWorkbook.Sheets("HTML1").Cells(i, 7).Value
Next
MsgBox "一覧を作成しました"
End Sub
Sub Ichiran_Make(objie As Object)
Dim el As Object
Dim n As Long
Sheets("一覧").Select
Cells.ClearContents
'タイトル入力
Cells(1, 1) = "No."
Cells(1, 2) = "TypeName"
Cells(1, 3) = "tagName"
Cells(1, 4) = "outerHTML"
Cells(1, 5) = "innerHTML"
Cells(1, 6) = "outerText"
'幅指定
Cells(1, 1).ColumnWidth = 5.63
Cells(1, 2).ColumnWidth = 9.63
Cells(1, 3).ColumnWidth = 4.75
Cells(1, 4).ColumnWidth = 12.38
Cells(1, 5).ColumnWidth = 12.38
Cells(1, 6).ColumnWidth = 12.38
For Each el In objie.document.all
n = n + 1
Cells(n + 1, 1) = n
Cells(n + 1, 2) = "'" & TypeName(el) 'TypeNameでオブジェクトのタイプを表示
Cells(n + 1, 3) = "'" & el.tagName 'タグの名前
Cells(n + 1, 4) = "'" & Left(el.outerHTML, 256)
Cells(n + 1, 5) = "'" & Left(el.innerHTML, 256)
Cells(n + 1, 6) = "'" & Left(el.outerText, 256)
Next el
End Sub