150行VBA代码的outlook rss插件

自己尝试着用vba写了一个outlook rss插件, 最基本的功能只需150行左右的代码就可以搞定. 感兴趣的朋友可以试试.

经常用outlook, 又喜欢rss的人可能知道newsgator. 这个outlook的rss 插件不是免费的, 最不爽的地方是要用它还得先安装20+M的dotnet Framework Redistributable Package(之后我的机器就变得很慢, 不知是不是这个原因).

后来自己尝试着用vba写了一个outlook rss插件, 最基本的功能只需150行左右的代码就可以搞定. 感兴趣的朋友可以试试. 这里要声明编程只是我的业余爱好, 所以代码写比较烂, 不完善的地方肯定很多. 真诚地希望高手们能开发出好用的outlook插件, 给大家免费使用.

我分两部分介绍: 第一部分是对代码的说明; 第二部分介绍如何使用这些代码.

第一部分:对代码的说明

这部分代码实现一个基本功能: 更新rss feed.

一共需要五个函数, 调用关系如下:

BRR_UpdateChannel->BRR_GetAndParseRSSFile->BRR_GetOldRssItemTitleForCheck ->BRR_IsNewRssItem->BRR_NewRssItem
• BRR_UpdateChannel, 获取当前outlook folder的"WebViewURL"属性, 其值就是rss feed, 比如"http://www.klogs.org/index.xml"
• BRR_GetAndParseRSSFile, 根据rss feed取得相应的rss文件并进行解析.
• BRR_GetOldRssItemTitleForCheck, 获取上次更新时保存在当前outlook folder中的rss条目的标题, 把它们放在一个字符串数组strOldRssItemTitle里,供下面的函数使用.
• BRR_IsNewRssItem, 判断从rss feed中读取的rss条目是否是新的, 如果是, 调用下面的函数
• BRR_NewRssItem, 在outlook中创立一个新的rss条目

全局变量

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

第一个函数BRR_UpdateChannel很简单, 就不多说什么了.

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

第二个函数BRR_GetAndParseRSSFile用到了ms的xml解析器(就是下面代码中的MSXML2对象), 通常装了较高版本的office(或者装有微软aoe系列的游戏)都会带有这个解析器. 在你的机器上搜索一下"Msxml*.dll". 我用的是"C:\Program Files\Common Files\Microsoft Shared\OFFICE11\Msxml5.dll". 在outlook的vba编辑器上, 选择菜单"Tool/References...", 把这个dll加为References.

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

第三个函数BRR_GetOldRssItemTitleForCheck 没什么好说的. 这段代码和我实际用的有所不同, 我把它简化了.

Sub BRR_GetOldRssItemTitleForCheck()
    Dim rssFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim olPostItem As Outlook.PostItem
    
    Set rssFolder = ActiveExplorer.CurrentFolder
    intCheckNumber = 200 ‘ 最多从当前的outlook文件夹中读取 200 条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

第四个函数BRR_IsNewRssItem 也没什么好说的.

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

第五个函数BRR_NewRssItem. 下面段代码和我实际用的也有所不同. 我注释掉的部分是自制的一个outlook form, 里面内嵌了一个浏览器, 这样当我双击rss条目时, 它就会根据条目的链接属性自动连接原文. 这里为简单起见, 使用outlook 自带的"IPM.Post".

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 = "Original link:" + link + "
" + description + ""
    olPost.Subject = title
    ‘Set rssItemUrl = olPost.UserProperties.Add("rssItemUrl", olText)
    ‘rssItemUrl.Value = link
    olPost.UnRead = True
    olPost.Save
    olPost.Post
End Sub

第二部分:如何使用

• 1. 在outlook vba editor中新建一个模块, 把这里的完整代码贴进去. 记得把Msxml*.dll (Msxml4.dll或Msxml5.dll都可以)加为reference, 如图2004.12.24.1所示.

  

  
  图2004.12.24.1
  

• 2. 在outlook中新建一个文件夹, 命名为"RssTest". 右键之, 在"Home Page"属性页中的Address栏填入rss feed的地址, 比如"http://www.365key.com/rss/ecoin/", 如图2004.12.24.2所示.

  

  
  图2004.12.24.2
  

• 3. (使"RssTest"为outlook当前文件夹), 运行宏"BRR_UpdateChannel", 等约10~20秒钟(取决于网络连接快慢), 搞定, 如图2004.12.24.3所示.

  

  
  图2004.12.24.3
  

【作者: ecoin】【访问统计: 12】【2004年12月24日 星期五 22:45】【 加入博采】【打印】