XML（RSS）を読み込んで、Excelに書き出す

メモ。
YahooのRSSをxmlReaderで読み込んで、Excelに書き出します。

XMLデータの例

<?xml version="1.0" encoding="UTF-8" ?> 
- <rss xmlns:blogChannel="http://backend.userland.com/blogChannelModule" version="2.0">
- <channel>
  <title>Yahoo!ニュース・トピックス - トップ</title> 
  <link>http://news.yahoo.co.jp/</link> 
  <description>Yahoo! JAPANのニュース・トピックスで取り上げている最新の見出しを提供しています。</description> 
  <language>ja</language> 
  <pubDate>Thu, 07 May 2015 12:47:52 +0900</pubDate> 
- <item>
  <title>箱根で火山性地震続く 警戒を</title> 
  <link>http://dailynews.yahoo.co.jp/fc/local/kanagawa/?id=6159142</link> 
  <pubDate>Thu, 07 May 2015 12:30:28 +0900</pubDate> 
  <enclosure length="133" url="http://i.yimg.jp/images/icon/photo.gif" type="image/gif" /> 
  <guid isPermaLink="false">yahoo/news/topics/6159142</guid> 
  </item>
- <item>
  <title>慰安婦世界遺産に 韓国で動き</title> 
  <link>http://dailynews.yahoo.co.jp/fc/domestic/ianfu/?id=6159140</link> 
  <pubDate>Thu, 07 May 2015 11:59:45 +0900</pubDate> 
  <guid isPermaLink="false">yahoo/news/topics/6159140</guid> 
  </item>
- <item>
  <title>女児誘拐未遂 元巡査が認める</title> 
  <link>http://dailynews.yahoo.co.jp/fc/domestic/abduction/?id=6159141</link> 
  <pubDate>Thu, 07 May 2015 12:30:28 +0900</pubDate> 
  <guid isPermaLink="false">yahoo/news/topics/6159141</guid> 
  </item>
- <item>
  <title>結婚コスパ悪い 東京の価値観</title> 
  <link>http://dailynews.yahoo.co.jp/fc/domestic/konkatsu/?id=6159127</link> 
  <pubDate>Thu, 07 May 2015 10:00:01 +0900</pubDate> 
  <enclosure length="133" url="http://i.yimg.jp/images/icon/photo.gif" type="image/gif" /> 
  <guid isPermaLink="false">yahoo/news/topics/6159127</guid> 
  </item>
- <item>
  <title>サル命名に批判 動物園は困惑</title> 
  <link>http://dailynews.yahoo.co.jp/fc/local/zoo_and_aquarium/?id=6159143</link> 
  <pubDate>Thu, 07 May 2015 12:30:28 +0900</pubDate> 
  <enclosure length="133" url="http://i.yimg.jp/images/icon/photo.gif" type="image/gif" /> 
  <guid isPermaLink="false">yahoo/news/topics/6159143</guid> 
  </item>
- <item>
  <title>真夜中の一戦 錦織が初戦突破</title> 
  <link>http://dailynews.yahoo.co.jp/fc/sports/nishikori_kei/?id=6159120</link> 
  <pubDate>Thu, 07 May 2015 12:32:32 +0900</pubDate> 
  <enclosure length="133" url="http://i.yimg.jp/images/icon/photo.gif" type="image/gif" /> 
  <guid isPermaLink="false">yahoo/news/topics/6159120</guid> 
  </item>
- <item>
  <title>GTO作者の妻 藤沢あやの出産</title> 
  <link>http://dailynews.yahoo.co.jp/fc/entertainment/baby/?id=6159138</link> 
  <pubDate>Thu, 07 May 2015 11:43:41 +0900</pubDate> 
  <guid isPermaLink="false">yahoo/news/topics/6159138</guid> 
  </item>
- <item>
  <title>武井咲 交際報道にコメント</title> 
  <link>http://dailynews.yahoo.co.jp/fc/entertainment/takei_emi/?id=6159135</link> 
  <pubDate>Thu, 07 May 2015 11:12:28 +0900</pubDate> 
  <enclosure length="133" url="http://i.yimg.jp/images/icon/photo.gif" type="image/gif" /> 
  <guid isPermaLink="false">yahoo/news/topics/6159135</guid> 
  </item>
  </channel>
  </rss>

Imports Microsoft.Office.Interop
Imports System.Xml
Public Class Form1

    Const YahooRSS As String = "http://rss.dailynews.yahoo.co.jp/fc/rss.xml"

    Dim xlApp As Excel.Application = Nothing
    Dim xlBookNew As Excel.Workbook = Nothing
    Dim xlSheetNew As Excel.Worksheet = Nothing

    Dim strNewPath As String
    Dim strNow As String

    Dim intY As Integer

    Dim blnErrFlag As Boolean = False

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        Try

            Create_Excel()   'Excelの生成

            Read_RSS()       'XMLパース＆Excelへの書き込み処理

        Catch ex As Exception

            MessageBox.Show("予期せぬエラーが発生しました・・・", "Error!",
                            MessageBoxButtons.OK,
                            MessageBoxIcon.Exclamation)

            blnErrFlag = True

        Finally

            '▼解放処理
            '　既存ファイル
            MRComObject(xlSheetNew)
            MRComObject(xlBookNew)

            xlApp.Quit()
            MRComObject(xlApp)

            xlSheetNew = Nothing
            xlBookNew = Nothing

            xlApp = Nothing

            If blnErrFlag = False Then

                Timer(0.5) 'サブプロシージャ呼び出し

                MessageBox.Show("完了しました。", "完了通知",
                                MessageBoxButtons.OK, MessageBoxIcon.Information)

            End If

            Application.Exit()
            End

        End Try


    End Sub
    Private Sub Read_RSS()

        '項目のセット
        With xlSheetNew
            .Cells(1, 1).Value = "title"
            .Cells(1, 2).Value = "link"
            .Cells(1, 3).Value = "pubDate"
            .Cells(1, 4).Value = "enclosure"
            .Cells(1, 5).Value = "guid"
            .Cells(1, 6).Value = "isPermaLink"
        End With

        intY = 1

        Try

            xlApp.ScreenUpdating = False

            Using xmlReader As XmlReader = xmlReader.Create(YahooRSS)

                xmlReader.ReadToFollowing("item")

                While xmlReader.Read

                    If xmlReader.NodeType = XmlNodeType.Element Then

                        Select Case xmlReader.LocalName

                            Case "title"

                                intY += 1 'titleの時はカウンターを加算
                                xlSheetNew.Cells(intY, 1).Value = xmlReader.ReadString()

                            Case "link"

                                xlSheetNew.Cells(intY, 2).Value = xmlReader.ReadString()

                            Case "pubDate"

                                xlSheetNew.Cells(intY, 3).Value = xmlReader.ReadString()

                            Case "enclosure"

                                If xmlReader.HasAttributes Then

                                    xlSheetNew.Cells(intY, 4).Value = xmlReader.GetAttribute("url")

                                End If

                            Case "guid"

                                xlSheetNew.Cells(intY, 5).Value = xmlReader.ReadString()

                                If xmlReader.HasAttributes Then

                                    xlSheetNew.Cells(intY, 6).Value = xmlReader.GetAttribute("isPermaLink")

                                End If

                        End Select

                    End If

                End While

            End Using

            xlApp.ScreenUpdating = True

            Create_Dir() 'サブプロシージャ呼び出し

            xlBookNew.SaveAs(strNewPath & "\" & strNow & "_RSS Reader.xlsx")

            xlBookNew.Close(False)

        Catch ex As Exception

            MessageBox.Show("XML読み込み時にエラーが発生しました・・・", "Error!",
                            MessageBoxButtons.OK,
                            MessageBoxIcon.Exclamation)

        End Try

    End Sub

    Private Sub Create_Excel()

        'Excel が既に起動されているかどうかを調べます--------------
        Try

            '第1引数を指定せずに GetObject 関数を呼び出すと、
            'アプリケーションのインスタンスへの参照が返されます
            'Excel が起動されていないと、エラーが発生
            '起動していればそのExcelを使用します
            xlApp = GetObject(, "Excel.Application")

        Catch ex As Exception

            'Excel が起動していないなら新規にインスタンスを生成します
            xlApp = CreateObject("Excel.Application")

        End Try
        '----------------------------------------------------------

        xlApp.Visible = True 'エクセルを表示（表示しなくてもOK）

        xlBookNew = xlApp.Workbooks.Add()    '新規ブック作成
        xlSheetNew = xlBookNew.Worksheets(1) 'シートオブジェクト化

    End Sub

    Private Sub Create_Dir() 'フォルダ作成

        strNow = Now()
        strNow = Replace(strNow, "/", ".")   '禁止符号を変換
        strNow = Replace(strNow, ":", ".")   '禁止符号を変換

        '-------------------------------------------------------------
        '20XX.MM.DD hh:mm:SS だと19文字
        '午前中は　20XX.MM.DD h:mm:SS　と時間が1桁表示で18文字になる

        If Len(strNow) <> 19 Then '午前時間のゼロ追加
            strNow = Microsoft.VisualBasic.Left(strNow, 11) & "0" &
                     Microsoft.VisualBasic.Right(strNow, 7)
        End If
        '-------------------------------------------------------------

        'サブフォルダ作成
        IO.Directory.CreateDirectory(Application.StartupPath & "\" & strNow)

        'サブフォルダのパスを変数に格納
        strNewPath = Application.StartupPath & "\" & strNow

    End Sub

    Private Sub MRComObject(ByVal objCom As Object) '■Comの解放処理

        Try
            System.Runtime.InteropServices.Marshal.ReleaseComObject(objCom)
        Catch ex As Exception
            objCom = Nothing
        Finally
            objCom = Nothing
        End Try

    End Sub

    Private Sub Timer(ByVal Cc As Double)

        Dim dblTimer As Double = Microsoft.VisualBasic.Timer

        Do While Microsoft.VisualBasic.Timer - dblTimer < Cc
            Application.DoEvents()
        Loop

    End Sub

End Class