【VBA】Webページの解析ツール（HTMLタグ・属性を一覧化）

2023年12月27日 13:52

WebページのHTMLを解析して、タグ・属性情報をシートへ書き出すツールを作りました。
とあるWebページを分析するために、一括で取得（リスト化）できるVBAツールがあったら便利だなぁ、と思ったのがきっかけ。どうせなら今後も使い回せるように、ある程度汎用性を持たせました。

【取得例】

このツールの使い所
・Webページ内のタグ・属性情報を一括リスト化したいとき
・特定タグ（例えば<INPUT>タグ）に絞って属性値を調査したいとき
・属性値を１つづつ比較・確認したいとき
…等のシチュエーションで重宝するはず。
また、このツールを友人等に配布して、代わりにVBA実行して貰い結果をフィードバックして貰うことで、遠隔でのWebページ調査も可能になるかも。

コード紹介

コードはこちら。

Private Sub TagAttributeList()
　'URLから、対象WebページのHTMLドキュメントを取得
　Dim URL As String
　Dim HTML As Object
　URL = "https://note.com/"
　Set HTML = CreateObject("htmlfile")
　HTML.body.innerHTML = getResponse(URL)
 
　'配列inData()の見出しを作成
　Dim inData() As String '貼付け用データ
　Dim Num As Long 'inDataの要素数
　ReDim inData(3, 0)
　inData(0, 0) = "種別"
　inData(1, 0) = "No."
　inData(2, 0) = "タグ名/属性名"
　inData(3, 0) = "値"

　'配列inData()の本文を作成
　Dim element As Object
　Dim ele As Object
　Dim i As Long
　On Error Resume Next
　For Each element In HTML.all
　　Select Case UCase(element.tagName)
　　Case "HTML", "HEAD", "BODY"
　　　'処理対象から外す
　　Case Else
　　'タグ名とその値をinData()へ格納
　　　Num = Num + 1
　　　i = i + 1
　　　ReDim Preserve inData(3, Num)
　　　inData(0, Num) = "tag"
　　　inData(1, Num) = i
　　　inData(2, Num) = "<" & element.tagName & ">"
　　　inData(3, Num) = element.innerText
　　　'タグ内の属性名とその値をinData()へ格納
　　　For Each ele In element.Attributes
　　　　If ele.NodeValue <> "" Then
　　　　　Num = Num + 1
　　　　　ReDim Preserve inData(3, Num)
　　　　　inData(0, Num) = "att"
　　　　　inData(2, Num) = ele.nodeName
　　　　　inData(3, Num) = ele.NodeValue
　　　　End If
　　　Next
　　End Select
　Next
　On Error GoTo 0
 
　'シートを初期化
　Dim sh As Worksheet
　Dim base As Range
　Set sh = ActiveSheet
　sh.Cells.Clear
　Set base = sh.Range("A3")
　With base.Resize(Num, 4)
　　.NumberFormatLocal = "@"
　　.Borders.LineStyle = xlContinuous
　End With
 
　'inData()をシートへ貼付け
　'要素数が多すぎると、Transpose関数の制約（マシンに依存）に引っ掛かってエラー発生
　If Num * 4 < 1000 Then 'とりあえず上限1000
　　base.Resize(Num, 4).Value = Application.WorksheetFunction.Transpose(inData)
　Else
　　Dim x As Long
　　Dim y As Long
　　Dim Tmp() As String
　　Tmp = inData
　　ReDim inData(Num, 4)
　　For x = 0 To Num - 1
　　　For y = 0 To 3
　　　　inData(x, y) = Tmp(y, x)
　　　Next
　　Next
　　base.Resize(Num, 4).Value = inData()
　End If
 
　'体裁を整える
　base.EntireColumn.ColumnWidth = 5
　base.Offset(, 1).EntireColumn.ColumnWidth = 5
　base.Offset(, 2).EntireColumn.ColumnWidth = 20
　base.Offset(, 3).EntireColumn.ColumnWidth = 60
　base.Resize(, 4).Interior.Color = RGB(217, 217, 217) '灰色
　base.Offset(-2).Value = URL
　base.Offset(-1).Value = HTML.Title
　Set base = Nothing
　Set sh = Nothing
End Sub


'引数として受け取ったURL（Webページ）のHTMLソース（テキスト）を返す
Private Function getResponse(ByVal URL As String) As String
　'HTTPリクエストを生成・送信
　Dim Req As Object
　Dim resText As String
　Set Req = CreateObject("MSXML2.ServerXMLHTTP")
　'Set Req = CreateObject("MSXML2.XMLHTTP")
　'Set Req = CreateObject("WinHttp.WinHttpRequest")
　Req.Open "GET", URL, False
　Req.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
　Req.send
　resText = Req.responseText

　'Webページの文字コードを取得
　'まずは、<meta>タグ内のCharset属性値を取得
　Dim CharCode As String
　Dim tempObj As Object
　Set tempObj = CreateObject("htmlfile")
　tempObj.body.innerHTML = resText
　On Error Resume Next
　For Each Elem In tempObj.getElementsByTagName("meta")
　　If Not Elem.Charset = "" Then
　　　CharCode = Elem.Charset
　　　Exit For
　　End If
　Next
　On Error GoTo 0
　Set tempObj = Nothing
　'更に、"charset="に続く文字列を検索して取得
　If CharCode = "" Then
　　If InStr(resText, "charset=") > 0 Then
　　　Dim S As Long
　　　Dim E As Long
　　　S = InStr(resText, "charset=") + 8
　　　E = InStr(S, resText, """")
　　　CharCode = Mid(resText, S, E - S)
　　End If
　End If
　Debug.Print "CharCode= " & CharCode
 
　'ADODB.Streamを使って文字化け補正
　If CharCode <> "" Then
　　CharCode = Replace(CharCode, " ", "") '空白を削除
　　CharCode = UCase(CharCode) '大文字へ変換
　　Dim ado As Object
　　Set ado = CreateObject("ADODB.Stream")
　　With ado
　　　.Type = 1 'adTypeBinary
　　　.Open
　　　.write Req.responseBody 'responseTextでなくresponseBodyを指定しバイナリデータを書き込み
　　　.Position = 0 'ストリーム先頭を指定
　　　.Type = 2 'adTypeText
　　　.Charset = CharCode
　　　getResponse = .ReadText 'ストリームからテキスト読取り
　　　.Close
　　End With
　　Set ado = Nothing
　Else
　　getResponse = resText
　　Debug.Print "対象Webページの文字コードが自動取得できませんでした。" & vbCrLf & _
　　"文字化けする場合は、手作業で文字コードを設定してください"
　End If
 
　'レスポンスをテキスト出力（確認用）
　'Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ResponseText.txt" For Output As #1
　'Print #1, resText
　'Close #1
　Set Req = Nothing
End Function

全体的な流れは、
・URLに対してGET送信（HTTP通信）
・HTTPレスポンスから文字コードを判別
・ADODB.Streamを使って、文字コードによる文字化け補正
・HTTPレスポンスからHTMLドキュメントオブジェクトを生成
・タグ情報を配列inData()へ格納
・属性情報を配列inData()へ格納
・配列inData()をシートへ書き出す
です。

使用上の注意点

GET送信して得られたレスポンスを元に、HTMLドキュメントオブジェクトを生成しています。なのでレスポンスに含まれていない情報は、当然、HTMLドキュメントにも含まれていないため解析・取得できません。
※動的に生成されるWebページのソースは一部取得できない可能性あり。

更に、フレーム内のソースも同じ理屈で、解析・取得できません。
フレームは<frame>または<iframe>タグ内にリンク先URL情報が記載されている筈です。フレーム内のソースを取得したいときは、そのリンク先URLを取得して再度ツール実行（そのリンク先に再度GET送信）してください。
こんな感じで正規表現で<iframe>タグを抽出すればOk。

　Dim response As String
　Dim reg As Object
　Dim regMatch As Object
　Dim i As Long
　Dim tagS As Long
　Dim attS As Long
　Dim attE As Long
　Dim URLs() As String
　ReDim URLs(1)

　response = "ここにHTTPレスポンステキストを代入"
　Set reg = CreateObject("VBScript.RegExp")
　With reg
　　.Pattern = "<iframe(.)* src=""[^""]+"""
　　.IgnoreCase = True '大文字小文字を区別しない
　　.Global = True '全体を検索
　　'Debug.Print "<iframe>タグは全部で" & .Execute(response).Count & "個です"
　　For i = 0 To .Execute(response).Count - 1
　　　'Debug.Print "<iframe>タグの文字数は" & .Execute(response)(i).Length & "です"
　　　tagS = .Execute(response)(i).firstindex
　　　attS = InStr(tagS, response, "src=") + 5
　　　attE = InStr(attS, response, """")
　　　ReDim Preserve URLs(UBound(URLs) + 1)
　　　URLs(i) = Mid(response, attS, attE - attS)
　　Next i
　End With
　Set reg = Nothing
　
　Debug.Print "配列URLs()に<iframe>内のリンク先URLが格納されました"

コードの補足

TagAttributeListプロシージャ
●「'配列inData()の本文を作成」の部分
SELECT文を使って処理対象のタグを指定しています。
上記例では"HTML", "HEAD", "BODY"を除いて情報取得していますが、例えば「CASE "INPUT"」などと書けば、タグ別に個別処理できます。
<INPUT>タグだけに絞ってシートへ書き出したい、等の調整ができます。

また、タグ内の属性情報の取得には注意が必要です。
Webページによっては、特定タグ（例えば全てのbuttonタグ）に対して属性が一括適用されている場合があります。1つのタグに大量の属性名「だけ」が設定されていて、属性の中身が空という状況も考えられます。
"このタグには6個の属性名が紐づいているけど、実際に属性値がセットされているのは2種類だけだ。"という具合ですね。
なので次の様な<button>タグの属性値を全部取得したいときは、以下のようにFor … Next文でループさせてもダメです。

【例】<button>タグ内の属性

　Dim element As Object 'elementはタグ要素（つまりHTMLドキュメントオブジェクト内の各Node）
　Dim j As long
　For j = 0 To element.Attributes.Length - 1
　　Debug.Print j & "番目の属性名：" & element.Attributes.Item(j).nodeName
　　Debug.Print j & "番目の属性値：" & element.Attributes.Item(j).NodeValue
　Next

Attribude.Lengthは、値がきちんと設定されている属性の数しか取得できないので、上記例だとi=0~1までの2回しかループせず、値が空のclass属性とname属性だけが取得されます。
欲しい情報（id属性とaria-label属性）をきっちり取るために、For each文で全体をループさせる必要があります。

●「inData()をシートへ貼付け」の部分
二次元配列inData()を、WorksheetFunction.Transpose関数で縦横入れ替えてシートへ貼り付ける処理ですが、要素数が多すぎるとエラー発生します。
要素数の上限値はマシンに依存する模様。
これは仕様なので仕方ありませんが、とりあえず安全をみて要素数1000以上の場合はTranspose関数を使わずに自力で縦横入れ替えることにしました。

getResponseプロシージャ
●「Webページの文字コードを取得」の部分
HTMLソース内に記載されている文字コードを取得するため、まずは<meta>タグ内にcharset属性がないか確認し、見つかれば値を取得します。
もし見つからなければ文字列検索で「charset」に続く文字を無理やり取得。
それでも見つからなければ、文字コードの取得は諦めます。

●「ADODB.Streamを使って文字化け補正」の部分
VBAでは扱える文字コードが限られるため、ADODB.Streamを使って文字化け対策しています。
Streamオブジェクトの操作としては…
１．TypeプロパティでStreamのデータ型を"バイナリ"指定。
２．OpenメソッドでStreamを開く。
３．Writeメソッドで、バイナリデータをStreamに書き込む。
４．PositionプロパティでStream内の位置を先頭へ戻す。
５．TypeプロパティでStreamのデータ型を"テキスト"指定。
６．Charsetプロパティで文字セットを指定。
７．ReadTextメソッドでStreamからバイトを読み取り、文字列を返す。
８．CloseメソッドでStreamを閉じる。
です。
なお、3の部分では、Streamオブジェクトへ書き込むデータは「テキストでなくバイナリデータ」を指定する必要があるので、req.responseTextではなくreq.responseBodyとしています。
5の部分では、Stream内の現在の位置が0（先頭）でないとタイプ変更が出来ないため、予め４にて位置変更しています。

その他（豆知識）
URLの末尾に#が付いている場合、#以下をURLフラグメントといいます。
ページ内の位置情報(#に続けて指定したid属性値)のところまでジャンプして、ブラウザに画面表示させる機能です。通常フラグメントの部分はサーバーへ送信されず、クライアント(ブラウザ)側で情報処理されるために使われます。
URL内に?が付いている場合、?以下をクエリパラメータといいます。
動的なページ生成用の引数として、または何らかの情報処理に使われる引数としてサーバーに送信されます。

URLフラグメントとクエリパラメータが混在する場合は、先にクエリパラメータ?を書いた後、続けてURLフラグメント#を書くことがルールになっています。