最近、このブログの記事数がかなりの数になってきまして過去記事を探すのに苦労するようになってきてしまいました。
そこで固定ページを作って簡単に記事を見つけられるようにしようと思ったのですが、なかなかいい方法が見つかりません。javascriptでサイトマップを作成するという方法もあるようなのですが、javascriptはあまり詳しくないので断念しました。
そこで、以前『Excel VBAでWebサービス - Excelでフィードを読もう（RSS2.0編）』というのがあったということを思い出しまして、この方法を利用して記事のリンクタグを作成するマクロを作ってみました。
シート構成
まずExcelのシートを次のように作成します。TOP
このシートにはURLと取得記事数の欄、そして「作成」ボタンがあります。
URLはBloggerのURL。セル名「URL」
取得記事数は、フィードで読み込むときの記事数になります。セル名「MAXRESULTS」
「作成」ボタン。これは図形を貼り付けています。
LIST
LISTシートは、作成した結果を表示するシートです。
１行目の各項目名のセルに名前を付けています。
タイトル・・・TITLE
投稿時間・・・PUBLISHED
ラベル・・・CATEGORY
件数・・・ENTRYCOUNT
タグ・・・TAG
このシート構成を踏まえて、以下のようにコードを書いていきます。
作成ボタンのクリックイベントハンドラ
作成ボタンを押したときのイベントハンドラです。入力されたURLや祝記事数をもとに取得したフィードからのデータをLISTシートに転記してソートしています。
Public Sub Create_Click()
On Error GoTo Err_Trap
Dim i As Integer
Dim url As String
Dim entryCnt As Integer
Dim maxResults As Integer
Dim setCnt As Integer
Dim feedUrl As String
Worksheets("TOP").Select
'URL
url = Range("URL").value
If Right(url, 1) <> "/" Then
url = url & "/"
End If
'取得記事数
maxResults = Range("MAXRESULTS").value
If Len(url) = 0 Then
MsgBox "URLが入力されていません。", vbExclamation, "注意"
Exit Sub
End If
ReDim EntryList(0)
EntryLinstIndex = 0
Dim remainCnt As Integer
Do
If remainCnt < 150 Then
feedUrl = url & "feeds/posts/default/?max-results=" & maxResults & "&start-index=" & (setCnt * 150) + 1
Else
feedUrl = url & "feeds/posts/default/?max-results=150" & "&start-index=" & (setCnt * 150) + 1
End If
'フィードの取得
entryCnt = GetAtomFeed(feedUrl)
setCnt = setCnt + 1
remainCnt = maxResults - (setCnt * 150)
Loop While (remainCnt > 0)
If entryCnt = 0 Then
'総件数が0の場合は、処理を中断
Exit Sub
End If
'最後の要素を削除
ReDim Preserve EntryList(EntryLinstIndex - 1)
'前回の記事をクリア
Dim startRow As Integer
Dim endRow As Integer
'LISTシートを選択
Worksheets("LIST").Select
Range("TITLE").Offset(1).Activate
startRow = ActiveCell.Row
endRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
'対象範囲を削除
If startRow <= endRow Then
Rows(startRow & ":" & endRow).Delete
End If
endRow = entryCnt + 1
'記事リストから、ワークシートに転記
For i = 0 To UBound(EntryList)
'タイトル
ActiveSheet.Hyperlinks.Add _
anchor:=Range("TITLE").Offset(i + 1), _
Address:=EntryList(i).link, _
TextToDisplay:=EntryList(i).title
'投稿日時
Range("PUBLISHED").Offset(i + 1) = EntryList(i).published
'ラベル
Range("CATEGORY").Offset(i + 1) = EntryList(i).category
'タグ
Range("TAG").Offset(i + 1) = "<a href=""" & EntryList(i).link & """>" & EntryList(i).title & "</a>"
Next
'件数を出す
Range("ENTRYCOUNT").Offset(1).Activate
ActiveCell.value = "=IF(C2="""","""",COUNTIF(C:C,C2))"
Selection.AutoFill Destination:=Range("D" & startRow & ":D" & endRow), Type:=xlFillDefault
'ラベルの多い順、ラベル名昇順、タイトル名昇順にソートする
ActiveWorkbook.Worksheets("LIST").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LIST").Sort.SortFields.Add Key:=Range("D" & startRow & ":D" & endRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("LIST").Sort.SortFields.Add Key:=Range("C" & startRow & ":C" & endRow), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("LIST").Sort.SortFields.Add Key:=Range("A" & startRow & ":A" & endRow), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("LIST").Sort
.SetRange Range("A1:E" & endRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'セル内を折り返して全体を表示
Selection.CurrentRegion.WrapText = True
Exit Sub
Err_Trap:
MsgBox Err.Number & " " & Err.description, vbCritical, "エラー"
End Sub
フィード取得
標準モジュールに下記のプロシージャを作成します。 実際のAtomフィードを取得する処理です。Public Function GetAtomFeed(url As String) As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
'HTTP通信によるリクエスト送信
Dim xmlhttp As MSXML2.xmlhttp 'HTTP通信用オブジェクトを格納
Dim status As String 'HTTPリクエストの成否を格納
Dim resText As String 'HTTPレスポンスを格納（テキスト）
'HTTP通信用オブジェクトの生成
Set xmlhttp = New MSXML2.xmlhttp
'GETメソッド、非同期通信で接続
xmlhttp.Open "GET", url, False
'HTTPリクエストを実送信
xmlhttp.send
'リクエスト成否の状態を取得
status = xmlhttp.statusText
If status <> "OK" Then
Set xmlhttp = Nothing 'HTTP通信用オブジェクトを解放
GetAtomFeed = -1
Exit Function
End If
'レスポンスを格納
resText = xmlhttp.responseText
'HTTP通信用オブジェクトを解放
Set xmlhttp = Nothing
'XMLデータの解析
Dim xmlDoc As MSXML2.DOMDocument
Dim rss As MSXML2.IXMLDOMElement
Dim itemList As MSXML2.IXMLDOMNodeList
Dim item As MSXML2.IXMLDOMNode
Set xmlDoc = New MSXML2.DOMDocument
'レスポンスをXML文書として格納
xmlDoc.LoadXML (resText)
'XML文書のrss要素にアクセス
Set rss = xmlDoc.DocumentElement
'記事を「item」要素のリストとして取得し、一旦配列変数に格納
Set itemList = rss.getElementsByTagName("entry")
Dim value As String
Dim xmlAttr As MSXML2.IXMLDOMAttribute
Dim categoryCnt As Integer
Dim categoryList() As String
Dim workEntry As Entry
categoryCnt = 0
ReDim categoryList(0)
categoryList(0) = ""
'記事リスト分ループ
For i = 0 To itemList.Length - 1
Set item = itemList(i)
'子ノード分ループ
For j = 0 To item.ChildNodes.Length - 1
value = item.ChildNodes(j).Text
Select Case item.ChildNodes(j).nodeName
Case "title" 'タイトル
workEntry.title = value
Case "link" 'リンクURL
Set xmlAttr = item.ChildNodes(j).Attributes.getNamedItem("rel")
If xmlAttr.value = "alternate" Then
Set xmlAttr = item.ChildNodes(j).Attributes.getNamedItem("href")
workEntry.link = xmlAttr.value
End If
Case "published" '投稿日時
If value <> "" Then
workEntry.published = TimeConvert(value)
End If
Case "category" 'ラベル
If categoryCnt > 0 Then
ReDim Preserve categoryList(categoryCnt)
End If
Set xmlAttr = item.ChildNodes(j).Attributes.getNamedItem("term")
categoryList(categoryCnt) = xmlAttr.value
categoryCnt = categoryCnt + 1
End Select
Next j
'配列に格納
For k = 0 To UBound(categoryList)
EntryList(EntryLinstIndex).title = workEntry.title
EntryList(EntryLinstIndex).link = workEntry.link
EntryList(EntryLinstIndex).published = workEntry.published
EntryList(EntryLinstIndex).category = categoryList(k)
EntryLinstIndex = EntryLinstIndex + 1
ReDim Preserve EntryList(EntryLinstIndex)
Next k
'初期化
categoryCnt = 0
ReDim categoryList(0)
workEntry.title = ""
workEntry.link = ""
workEntry.published = ""
Next i
Set xmlDoc = Nothing 'XMLオブジェクトを解放
GetAtomFeed = EntryLinstIndex
End Function
投稿日時の表示形式を変換
Atomフィードで取得した投稿日時は、「2017-03-18T22:27:00.001+09:00」というような形式をしているので、これを「yyyy/mm/dd hh:nn」形式に変換するプロシージャです。Private Function TimeConvert(published As String) As Date
Dim workStr As String
'"-"を"/"に変更
workStr = Replace(published, "-", "/")
'"T"を空白に変更
workStr = Replace(workStr, "T", " ")
'左から16桁分だけ取得
workStr = Left(workStr, 16)
TimeConvert = CDate(workStr)
End Function
構造体定義など
そのほかに、構造体定義とグローバル変数を下記のように定義しています。'記事を格納する構造体
Public Type Entry
title As String 'タイトル
link As String 'リンクURL
published As String '投稿日時
category As String 'ラベル
End Type
'記事リストを格納する配列
Public EntryList() As Entry
Public EntryLinstIndex As Integer
使い方
使い方は、URLにBloggerのURLを入力し、取得したい記事数を入力します。 そして、あとは作成ボタンを押すだけです。 実行されるとLISTシートのほうにリンクタグを作成されます。
＜参考サイト＞
Excel VBAでWebサービス - Excelでフィードを読もう（RSS2.0編） (1) フィードについて - マイナビニュース
クリボウの Blogger 入門- Blogger のフィード URL とパラメータ
[Excel VBA] XMLの読み込み- 遊び人の得意技はパルプンテ
スポンサーリンク