自己嘗試著(zhù)用vba寫(xiě)了一個(gè)outlook rss插件, 最基本的功能只需150行左右的代碼就可以搞定. 感興趣的朋友可以試試.
經(jīng)常用outlook, 又喜歡rss的人可能知道newsgator. 這個(gè)outlook的rss 插件不是免費的, 最不爽的地方是要用它還得先安裝20+M的dotnet Framework Redistributable Package(之后我的機器就變得很慢, 不知是不是這個(gè)原因).
后來(lái)自己嘗試著(zhù)用vba寫(xiě)了一個(gè)outlook rss插件, 最基本的功能只需150行左右的代碼就可以搞定. 感興趣的朋友可以試試. 這里要聲明編程只是我的業(yè)余愛(ài)好, 所以代碼寫(xiě)比較爛, 不完善的地方肯定很多. 真誠地希望高手們能開(kāi)發(fā)出好用的outlook插件, 給大家免費使用.
我分兩部分介紹: 第一部分是對代碼的說(shuō)明; 第二部分介紹如何使用這些代碼.
這部分代碼實(shí)現一個(gè)基本功能: 更新rss feed.
一共需要五個(gè)函數, 調用關(guān)系如下:
全局變量
‘字符串數組, 保存舊的rss條目的標題, 以供比較是否有新條目
Dim strOldRssItemTitle(200) As String
‘整型變量, 讀取intCheckNumber條舊rss條目標題到strOldRssItemTitle數組中,
‘這個(gè)數應當小于strOldRssItemTitle的容量
Dim intCheckNumber As Integer
‘整型變量,實(shí)際更新了多少條rss條目
Dim intUpdatedItemNumber As Integer
第一個(gè)函數BRR_UpdateChannel很簡(jiǎn)單, 就不多說(shuō)什么了.
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
第二個(gè)函數BRR_GetAndParseRSSFile用到了ms的xml解析器(就是下面代碼中的MSXML2對象), 通常裝了較高版本的office(或者裝有微軟aoe系列的游戲)都會(huì )帶有這個(gè)解析器. 在你的機器上搜索一下"Msxml*.dll". 我用的是"C:\Program Files\Common Files\Microsoft Shared\OFFICE11\Msxml5.dll". 在outlook的vba編輯器上, 選擇菜單"Tool/References...", 把這個(gè)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
‘字符串變量, 用于存儲一個(gè)rss條目的標題, 鏈接和條目摘要
Dim strEntryTitle As String
Dim strEntryLink As String
Dim strEntryDescription As String
On Error GoTo HandleErr
Set odoc = New MSXML2.DOMDocument
‘加載rss feed, 等待完成, 如果不能加載(如網(wǎng)絡(luò )不通或網(wǎng)站關(guān)閉), 則顯示錯誤信息退出.
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條目的標題提取出來(lái)保存
BRR_GetOldRssItemTitleForCheck
‘從這里開(kāi)始對xml文件進(jìn)行解析
Set oRoot = odoc.documentElement
‘這一段代碼處理符合rss0.92~rss2.0協(xié)議的xml文件, 如http://www.blogchina.com/xml/1_rss0.92.xml
‘我只關(guān)心三個(gè)最基本的信息,即:條目的標題, 鏈接和摘要. 你可以根據需要處理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中生成一個(gè)新rss條目
If BRR_IsNewRssItem(strEntryTitle) Then
BRR_NewRssItem strEntryTitle, strEntryLink, strEntryDescription
intUpdatedItemNumber = intUpdatedItemNumber + 1
End If
End If
Next oItem
‘下面這一段代碼處理符合rdf 協(xié)議的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協(xié)議, 如atom, 處理代碼放下面.
ExitHere:
Exit Sub
HandleErr:
MsgBox "Error " & Err.Number & ": " & Err.description
Resume ExitHere
Resume
End Sub
第三個(gè)函數BRR_GetOldRssItemTitleForCheck 沒(méi)什么好說(shuō)的. 這段代碼和我實(shí)際用的有所不同, 我把它簡(jiǎn)化了.
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
第四個(gè)函數BRR_IsNewRssItem 也沒(méi)什么好說(shuō)的.
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
第五個(gè)函數BRR_NewRssItem. 下面段代碼和我實(shí)際用的也有所不同. 我注釋掉的部分是自制的一個(gè)outlook form, 里面內嵌了一個(gè)瀏覽器, 這樣當我雙擊rss條目時(shí), 它就會(huì )根據條目的鏈接屬性自動(dòng)連接原文. 這里為簡(jiǎn)單起見(jiàn), 使用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:
" + description + ""
olPost.Subject = title
‘Set rssItemUrl = olPost.UserProperties.Add("rssItemUrl", olText)
‘rssItemUrl.Value = link
olPost.UnRead = True
olPost.Save
olPost.Post
End Sub
聯(lián)系客服
