TDK を取得する 方法

EXCELのB列にあるURLリストからWEB上の
情報をリスト化しちゃうマクロ（VBA）

ALT+F8 で入れれば結構がっちり取り出せちゃう。

title description keywords author robots copyright og:title og:description og:image og:url og:type site_name fb:admins
METAタグの付け方が1行であることが条件ですが・・・・

‘プログラム1｜プログラム開始
Sub GetWebPagesTDK()
Dim url As Range
Dim Http, buf As String
Dim re, mc, i
Set Http = CreateObject(“MSXML2.XMLHTTP”)
Set re = CreateObject(“VBScript.RegExp”)

Set url = Range(“b2”)
Do While (url.Value <> “”)
i = i + 1

Application.StatusBar = “(” & i & “/行目を処理中…)”

buf = “”
Http.Open “GET”, url.Value, False
Http.send
With CreateObject(“ADODB.Stream”)
On Error Resume Next
.Open
.Type = 2 ‘adTypeText
.Charset = “unicode”
.Writetext Http.responseBody
.Position = 0
.Charset = “utf-8”
buf = .ReadText()
.Close
End With

With re
.IgnoreCase = True
.Global = True

‘title、description、keywordsを取得して出力
.Pattern = “<title>(.*?)</title>”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 1) = mc(0).SubMatches(0)

.Pattern = “meta\s+?name.*?description.*?content=.*?[“”‘]*?[\s\S](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 2) = mc(0).SubMatches(0)

.Pattern = “meta\s+?content=.*?[“”‘]*?[\s\S](.*?)[‘””]?name.*?description.*”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 2) = mc(0).SubMatches(0)

.Pattern = “meta\s+?name.*?keywords.*?content=.*?[“”‘]*?[\s\S](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 3) = mc(0).SubMatches(0)

.Pattern = “meta\s+?content=.*?[“”‘](.*?)[‘””]?name.*?keywords.*”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 3) = mc(0).SubMatches(0)

‘その他要素（author、robots、copyright）を取得して出力
.Pattern = “meta\s+?name.*?author.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 4) = mc(0).SubMatches(0)

.Pattern = “meta\s+?name.*?robots.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 5) = mc(0).SubMatches(0)

.Pattern = “meta\s+?name.*?copyright.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 6) = mc(0).SubMatches(0)

‘OGPの各パラメータを取得して出力
.Pattern = “meta\s+?property.*?og:title.*?content=.*?[“”‘]*?[\s\S](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 7) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?og:description.*?content=.*?[“”‘]*?[\s\S](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 8) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?og:image.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 9) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?og:url.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 10) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?og:type.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 11) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?og:site_name.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 12) = mc(0).SubMatches(0)

.Pattern = “meta\s+?property.*?fb:admins.*?content=.*?[‘””](.*?)[‘””]”
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 13) = mc(0).SubMatches(0)

End With
Set url = url.Offset(1, 0)

Loop
Set Http = Nothing
Set re = Nothing
End Sub

excel Python VBA [AI] [DX] [FreeBSD12] [WEBディレクション] [WordPress] [思考] [技術]