150行VBA代码的outlook rss插件

评论：界面类似feedemon
自己尝试着用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】【加入博采】【打印】
_xyz