2017年4月23日

【Excel】Bloggerのフィード情報を読み込んで記事のリンクタグを作成するマクロを作ってみた

2017年4月23日 (日) 19:48 in , ,


最近、このブログの記事数がかなりの数になってきまして過去記事を探すのに苦労するようになってきてしまいました。

そこで固定ページを作って簡単に記事を見つけられるようにしようと思ったのですが、なかなかいい方法が見つかりません。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シートに転記してソートしています。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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フィードを取得する処理です。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
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」形式に変換するプロシージャです。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
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


構造体定義など

そのほかに、構造体定義とグローバル変数を下記のように定義しています。
1
2
3
4
5
6
7
8
9
10
11
'記事を格納する構造体
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の読み込み- 遊び人の得意技はパルプンテ

　
　

スポンサーリンク



Follow Me on Pinterest
Clip to Evernote