Noem me een sukkel, maar ik vind het leuk om “Quotes” van bekende mensen onderaan mijn mail te tonen. Om dit te bewerkstelligen zijn er verschillende addons te downloaden. Deze kosten echter allemaal geld en maken gebruik van een vast aantal quotes. Ik wilde echter een onberkt aantal verschillende quotes en ik wilde er niet voor betalen.
Op het internet zijn er verschillende sites waar je een Quote van de dag kunt downloaden. Ook zij er sites waar je deze Quote van de dag als RSS kunt downloaden.
Het idee nu is om bij het oepnen van een nieuwe mail deze RSS uit te lezen, en dat onderaan je mail te plaatsen.
Hiervoor heb ik binnen Outlook 2007 een signature ( handtekening ) gedefinieerd. In deze handtekening heb ik een keyword “<<Quote>>” opgenomen. Deze handtekening word als html bestand opgeslagen op de harde schijf van de computer. Bij het openen van een nieuw mailitem word dit bestand uitgelezen, en het keyword “<<Quote>>” word vervangen door een willekeurige Quote uit de RSS download.
Alles wat hiervoor nodig is is een stukje VBA, en het werkt als een trein.
Hieronder is de module code te zien en om deze te laten werken is er nog hetvolgende nodig:
- Installeer ChilKat ActiveX component voor het uitlezen van de RSS ( download )
- Zorg ervoor dat het event Application_ItemLoad de volgende code bevat:
Private Sub Application_ItemLoad(ByVal Item As Object)
editSignature "Quotes", ""
editSignature "Quotes", getQuote()
End Sub
Module code:
Const CONST_RSS_URL = "http://feeds.feedburner.com/brainyquote/QUOTEBR" '"http://www.quotationspage.com/data/mqotd.rss"
Public Function getQuote() As String
Dim rss As New ChilkatRss
Dim arrOut() As String
Dim tmp As String
Dim success As Long
getQuote = ""
' Download from the feed URL:
success = rss.DownloadRss(CONST_RSS_URL)
If (success <> 1) Then
Exit Function
End If
' Get the 1st channel.
Dim rssChannel As ChilkatRss
Set rssChannel = rss.GetChannel(0)
If (rssChannel Is Nothing) Then
Exit Function
End If
' For each item in the channel, display the title, link,
' publish date, and categories assigned to the post.
Dim numItems As Long
numItems = rssChannel.numItems
Dim i As Long
ReDim arrOut(numItems - 1)
For i = 0 To numItems - 1
Dim rssItem As ChilkatRss
Set rssItem = rssChannel.GetItem(i)
tmp = rssItem.GetString("title") & " :" & "<br>"
tmp = tmp & rssItem.GetString("description")
arrOut(i) = tmp
Next
getQuote = arrOut(Rand(0, UBound(arrOut)))
End Function
Public Function Rand(ByVal Low As Long, _
ByVal High As Long) As Long
Rand = Int((High - Low + 1) * Rnd) + Low
End Function
Public Sub editSignature(sigName As String, signatureText As String)
Dim sigPath As String
Dim fso As Object
Dim ts As Object
Dim oldSig As String
Dim newSig As String
Dim newQuote As String
Dim CONST_EMPTY_QUOTE As String
Dim intStars As Integer
CONST_EMPTY_QUOTE = "<<Quote>>"
intStars = 100
On Error GoTo errh
sigPath = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Handtekeningen\" & sigName & ".htm"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sigPath).OpenAsTextStream(1, -2)
oldSig = ts.readall
ts.Close
If signatureText = "" Then
newQuote = Mid(oldSig, InStr(oldSig, String(intStars, "*")))
newQuote = Left(newQuote, InStr(intStars + 4, newQuote, String(intStars, "*")) + (intStars - 1))
'MsgBox (newQuote)
signatureText = CONST_EMPTY_QUOTE
CONST_EMPTY_QUOTE = newQuote
Else
signatureText = String(intStars, "*") & "<br>" & signatureText & "<br>" & String(intStars, "*")
End If
Set ts = Nothing
Set ts = fso.OpenTextFile(sigPath, 2)
newSig = Replace(oldSig, CONST_EMPTY_QUOTE, signatureText)
'MsgBox newSig
ts.Write (newSig)
ts.Close
errh:
Set ts = Nothing
Set fso = Nothing
End Sub
