有没有 outlook 2003 使用的 RSS 阅读器呢？

yourliang

有没有outlook 2003下面使用的RSS 阅读器呢？我想要VBA编写的程式，大家有没有想过开发一个呢？

simpleson

'字符串数组, 保存旧的rss条目的标题, 以供比较是否有新条目
Dim strOldRssItemTitle(200) As String
'整型变量, 读取intCheckNumber条旧rss条目标题到strOldRssItemTitle数组中,
'这个数应当小于strOldRssItemTitle的容量
Dim intCheckNumber As Integer
'整型变量,实际更新了多少条rss条目
Dim intUpdatedItemNumber As Integer

Sub BRR_UpdateChannel()
    Dim strRssFeed As String
    strRssFeed = ActiveExplorer.CurrentFolder.WebViewURL
    intUpdatedItemNumber = 0
    If strRssFeed <> "" Then
        BRR_GetAndParseRSSFile strRssFeed
    Else
        MsgBox "Please define rss feed for this channel first."
    End If
End Sub

Sub BRR_GetAndParseRSSFile(url As String)

    'msxml解析器用的对象变量
    Dim odoc As MSXML2.DOMDocument
    Dim oRoot As MSXML2.IXMLDOMNode
    Dim oChannel As MSXML2.IXMLDOMNode
    Dim oItem As MSXML2.IXMLDOMNode
    Dim oEntry As MSXML2.IXMLDOMNode
    Dim oAttributes As MSXML2.IXMLDOMNamedNodeMap
    Dim oChildren As MSXML2.IXMLDOMNodeList
    Dim oChild As MSXML2.IXMLDOMNode

    Dim bSuccess As Boolean    ' 布尔变量, 表示能否成功加载rss feed

    '字符串变量, 用于存储一个rss条目的标题, 链接和条目摘要
    Dim strEntryTitle As String
    Dim strEntryLink As String
    Dim strEntryDescription As String
           
    'On Error GoTo HandleErr
    Set odoc = New MSXML2.DOMDocument

    '加载rss feed, 等待完成, 如果不能加载(如网络不通或网站关闭),
    '则显示错误信息退出.
    odoc.async = False
    odoc.validateOnParse = False

    bSuccess = odoc.Load(url)
    If Not bSuccess Then
      MsgBox "rss feed load error!"
      GoTo ExitHere
    End If
   
    '在解析加载的rss xml文件以前, 先把保存在当前outlook  folder中的旧rss条目
    '的标题提取出来保存
    BRR_GetOldRssItemTitleForCheck

    '从这里开始对xml文件进行解析
    Set oRoot = odoc.documentElement
   
    '这一段代码处理符合rss0.92~rss2.0协议的xml文件, 如
    'http://www.blogchina.com/xml/1_rss0.92.xml
    '我只关心三个最基本的信息,即:条目的标题, 链接和摘要.
    '你可以根据需要处理xml文件中的其它信息
    Set oChannel = oRoot.FirstChild
     'Debug.Print  MsgBox oChannel.nodeName
    For Each oItem In oChannel.childNodes
        If oItem.nodeName = "item" Then
            For Each oEntry In oItem.childNodes
             Select Case oEntry.nodeName
                Case "title"
                    strEntryTitle = oEntry.Text
                Case "link"
                    strEntryLink = oEntry.Text
                Case "description"
                    strEntryDescription = oEntry.Text
                Case "category" 'specially for rss 2.0
                    strEntryTitle = (oEntry.Text & "::" & strEntryTitle)
             End Select
            Next oEntry

            '如果有更新,则调用BRR_NewRssItem在outlook中生成一个新rss条目
            If BRR_IsNewRssItem(strEntryTitle) Then
                BRR_NewRssItem strEntryTitle, strEntryLink, strEntryDescription
                intUpdatedItemNumber = intUpdatedItemNumber + 1
            End If
        End If
    Next oItem
     
    '下面这一段代码处理符合rdf 协议的xml文件, 如
    'http://xchina.linux.net.cn/rss.php
    Set oChildren = oRoot.childNodes
    For Each oChild In oChildren
        If oChild.nodeName = "item" Then
            For Each oEntry In oChild.childNodes
             Select Case oEntry.nodeName
                Case "title"
                    strEntryTitle = oEntry.Text
                Case "link"
                    strEntryLink = oEntry.Text
                Case "description"
                    strEntryDescription = oEntry.Text
             End Select
            Next oEntry
            If BRR_IsNewRssItem(strEntryTitle) Then
                BRR_NewRssItem strEntryTitle, strEntryLink, strEntryDescription
                intUpdatedItemNumber = intUpdatedItemNumber + 1
            End If
        End If
    Next oChild

    '如果有其它rss协议, 如atom, 处理代码放下面.

ExitHere:
    Exit Sub
HandleErr:
        MsgBox "Error " & Err.Number & ": " & Err.description
        Resume ExitHere
        Resume
End Sub

Sub BRR_GetOldRssItemTitleForCheck()
    Dim rssFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim olPostItem As Outlook.PostItem
   
    Set rssFolder = ActiveExplorer.CurrentFolder
    intCheckNumber = 50 ' 最多从当前的outlook文件夹中读取 50 条old rss items
    If rssFolder.Items.Count < intCheckNumber Then
        intCheckNumber = rssFolder.Items.Count
    End If
   
    Set Items = ActiveExplorer.CurrentFolder.Items
    Set olPostItem = Items.GetFirst
    For I = 1 To intCheckNumber
        strOldRssItemTitle(I - 1) = olPostItem.Subject
        Set olPostItem = Items.GetNext
    Next I
End Sub

Function BRR_IsNewRssItem(title As String)
    BRR_IsNewRssItem = True
    For I = 1 To intCheckNumber
        If title = strOldRssItemTitle(I - 1) Then
            BRR_IsNewRssItem = False
            Exit Function
        End If
    Next I
End Function

Sub BRR_NewRssItem(title As String, link As String, description As String)
    Dim olPost As Outlook.PostItem
    Dim rssItemUrl As Outlook.UserProperty
   
    'Set olPost = ActiveExplorer.CurrentFolder.Items.Add("IPM.Post.fmPostWithWebBrowser")
    Set olPost = ActiveExplorer.CurrentFolder.Items.Add("IPM.Post")
    olPost.BodyFormat = olFormatHTML
    olPost.HTMLBody = "<body>Original link:<a href=" + link + ">" + link + "</a><br><hr>" + description + "</body>"
    olPost.Subject = title
    'Set rssItemUrl = olPost.UserProperties.Add("rssItemUrl", olText)
    'rssItemUrl.Value = link
    olPost.UnRead = True
    olPost.Save
    olPost.Post
End Sub

simpleson

网上找的，可惜下载不了。
  bSuccess = odoc.Load(url)        '这行代码出错，不论怎样，总是载入失败
    If Not bSuccess Then
      MsgBox "rss feed load error!"
      GoTo ExitHere
    End If

yourliang

odoc估计需要引用一个额外的MSXML2控件才行。但是具体哪一个我也不清楚哇。你的那段代码是不是只能够下载有限个新闻的？