見出し画像

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

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

【取得例】

タグと属性の取得結果

このツールの使い所
・Webページ内のタグ・属性情報を一括リスト化したいとき
・特定タグ(例えば<INPUT>タグ)に絞って属性値を調査したいとき
・属性値を1つづつ比較・確認したいとき
…等のシチュエーションで重宝するはず。
また、このツールを友人等に配布して、代わりに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オブジェクトの操作としては…
1.TypeプロパティでStreamのデータ型を"バイナリ"指定。
2.OpenメソッドでStreamを開く。
3.Writeメソッドで、バイナリデータをStreamに書き込む。
4.PositionプロパティでStream内の位置を先頭へ戻す。
5.TypeプロパティでStreamのデータ型を"テキスト"指定。
6.Charsetプロパティで文字セットを指定。
7.ReadTextメソッドでStreamからバイトを読み取り、文字列を返す。
8.CloseメソッドでStreamを閉じる。
です。
なお、3の部分では、Streamオブジェクトへ書き込むデータは「テキストでなくバイナリデータ」を指定する必要があるので、req.responseTextではなくreq.responseBodyとしています。
5の部分では、Stream内の現在の位置が0(先頭)でないとタイプ変更が出来ないため、予め4にて位置変更しています。

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

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




この記事が気に入ったらサポートをしてみませんか?