Atom形式のフィードを読んで指定のファイルより新しいエントリを取得するVBScript

本当はチャットツールに差分をPOSTするところまで実装する予定だったが、力尽きたので今日はここまで。

Option Explicit

Dim FEED_URL
Dim PREV_RSS_UPDATE_DATE_FILE

'FEED_URL = "http://www.data.jma.go.jp/developer/xml/feed/regular.xml"
FEED_URL = "http://example.com"
PREV_FEED_UPDATE_DATE_FILE = "C:\Users\hayak\TMP\prevDate.txt"

' 本処理
Dim xml ' XMLDOMオブジェクト

GetFeed FEED_URL, xml ' フィードをダウンロード

' 更新確認
if StrComp(GetPrevUpdateDate(), GetUpdateDate(xml)) = -1 Then
    WScript.Echo GetNewEntry(xml, GetPrevUpdateDate())
End If

' フィードを取得してXMLDOMオブジェクトを格納する
Sub GetFeed(rssURL, xmlDom)
    Dim xmlhttp 
    Set xmlhttp = WScript.CreateObject("MSXML2.XMLHTTP.3.0") 
    Dim resText 

    xmlhttp.Open "GET", rssURL, False 
    xmlhttp.send 

    If xmlhttp.status <> 200 Then
        WScript.Echo "リクエスト失敗"
        Set xmlhttp = Nothing 
        WScript.Quit
    End If

    ParseXML xmlhttp.responseText, xmlDom
    Set xmlhttp = Nothing 
End Sub

' XML文字列をパースしてXMLDOMオブジェクトを格納する
Sub ParseXML(xmlString, ByRef xmlDom)
    Dim loadSuccess
    Set xmlDom = WScript.CreateObject("MSXML2.DOMDocument")
    
    loadSuccess = xmlDom.LoadXML(xmlString)

    If Not loadSuccess Then
      WScript.Echo xmlDom.parseError.errorCode
      WScript.Echo xmlDom.parseError.reason
      WScript.Echo xmlDom.parseError.line
      WScript.Echo xmlDom.parseError.linepos
      WScript.Echo xmlDom.parseError.filepos
      WScript.Echo xmlDom.parseError.srcText
      WScript.Echo xmlDom.parseError.url
      Set xmlDom = Nothing
      WScript.Quit
    End If
End Sub

' ファイルを読んで文字列を格納する
Sub ReadFile(filePath, textStr)
    Dim fs
    Dim tf

    Set fs = WScript.CreateObject("Scripting.FileSystemObject")
    Set tf = fs.OpenTextFile(filePath, 1)

    textStr = tf.ReadAll
    tf.Close
    Set fs = Nothing
    Set tf = Nothing
End Sub

' XMLから更新日を取得する
Function GetUpdateDate(xml)
    GetUpdateDate = xml.getElementsByTagName("updated").Item(0).Text
End Function

' ファイルから以前の更新日を取得する
Function GetPrevUpdateDate()
    ReadFile PREV_FEED_UPDATE_DATE_FILE, GetPrevUpdateDate
End Function

' 以前の更新日より新しいエントリを取得する
Function GetNewEntry(xml, prevDate)
    Dim entry
    Dim result
    result = "未読のentryがあります  \n"
    For Each entry in xml.getElementsByTagName("entry")
        AppendNewEntry prevDate, entry, result
    Next
    GetNewEntry = result
End Function

' 新しいエントリのみ追加する
Sub AppendNewEntry(prevDate, entry, result)
    Dim updateDate
    updateDate = entry.getElementsByTagName("updated").Item(0).Text
    If StrComp(GetPrevUpdateDate(), updateDate) = -1 Then
        Dim title
        Dim link
        title = entry.getElementsByTagName("title").Item(0).Text
        link = entry.getElementsByTagName("link").Item(0).getAttribute("href")
        result = result & title & "  \n" & link & "  \n" & "  \n" 
    End If
End Sub